X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=ba7cbc966646cfeede033b0be4a0a70b503c912c;hb=refs%2Ftags%2Ft-gnus-6_13_2-12;hp=6c329c037f9b1fc9ab636a8900b13aa274df84db;hpb=8cfa576451fc393ec8ad0de58a89a0afd4343fbf;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 6c329c0..ba7cbc9 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,8 +1,9 @@ -;;; gnus-util.el --- utility functions for Gnus +;;; gnus-util.el --- utility functions for Semi-gnus ;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; Tatsuya Ichikawa +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -35,6 +36,7 @@ (require 'nnheader) (require 'message) (require 'time-date) +(eval-when-compile (require 'static)) (eval-and-compile (autoload 'rmail-insert-rmail-file-header "rmail") @@ -50,10 +52,12 @@ "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"))) + (buf (make-symbol "buf")) + (frame (make-symbol "frame"))) `(let* ((,tempvar (selected-window)) (,buf ,buffer) - (,w (get-buffer-window ,buf 'visible))) + (,w (get-buffer-window ,buf 'visible)) + ,frame) (unwind-protect (progn (if ,w @@ -62,7 +66,9 @@ (set-buffer (window-buffer ,w))) (pop-to-buffer ,buf)) ,@forms) - (select-window ,tempvar))))) + (setq ,frame (selected-frame)) + (select-window ,tempvar) + (select-frame ,frame))))) (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) @@ -74,6 +80,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 +114,34 @@ (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)) +(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)))) + )) +(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)))) + )) (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -465,8 +496,7 @@ If N, return the Nth ancestor instead." (set-buffer gnus-work-buffer) (erase-buffer)) (set-buffer (gnus-get-buffer-create gnus-work-buffer)) - (kill-all-local-variables) - (mm-enable-multibyte))) + (kill-all-local-variables))) (defmacro gnus-group-real-name (group) "Find the real name of a foreign newsgroup." @@ -506,7 +536,7 @@ If N, return the Nth ancestor instead." ((gnus-functionp function) ) (t - (error "Invalid sort spec: %s" function))))if + (error "Invalid sort spec: %s" function)))) (if (cdr funs) `(or (,function ,first ,last) (and (not (,function ,last ,first)) @@ -547,6 +577,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) @@ -688,7 +733,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) + (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) @@ -729,7 +774,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 +801,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)) @@ -797,73 +843,58 @@ ARG is passed to the first function." ;;; .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 + (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*") - (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*")))))) + (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 + (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. + (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))))) (defun gnus-netrc-machine (list machine) "Return the netrc values from LIST for MACHINE or for the default entry." @@ -939,6 +970,56 @@ ARG is passed to the first function." (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 &optional full-names) + (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" + (if full-names + (symbol-name sym) + (gnus-group-real-name (symbol-name sym))) + (cdr (symbol-value sym)) + (car (symbol-value sym)))))) + hashtb)))) + (defun gnus-write-active-file-as-coding-system + (coding-system file hashtb &optional full-names) + (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" + (if full-names + (symbol-name sym) + (gnus-group-real-name (symbol-name sym))) + (cdr (symbol-value sym)) + (car (symbol-value sym)))))) + hashtb)))) + ) + (provide 'gnus-util) ;;; gnus-util.el ends here