X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=e566243481c5a615a131f0416a2edc5945f76c02;hb=e38b8583e06c97ca60e8db4ba9555b9a5bee9214;hp=532429b2d374f38192e33b7972d6c43f2dfc0d4f;hpb=c8b25eebe2bfccd8b707d8c9e8ffa0d88d4a20af;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 532429b..e566243 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,8 +1,10 @@ -;;; 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, 1997, 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; Tatsuya Ichikawa +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -30,8 +32,10 @@ ;;; Code: -(require 'custom) (eval-when-compile (require 'cl)) +(eval-when-compile (require 'static)) + +(require 'custom) (require 'nnheader) (require 'message) (require 'time-date) @@ -50,10 +54,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 +68,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 +82,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 +116,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) + (defalias 'gnus-point-at-bol 'point-at-bol)) + ((fboundp 'line-beginning-position) + (defalias '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) + (defalias 'gnus-point-at-eol 'point-at-eol)) + ((fboundp 'line-end-position) + (defalias '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." @@ -164,8 +197,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." @@ -291,7 +324,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 +343,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 ""))) @@ -448,14 +483,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 () @@ -465,8 +492,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." @@ -504,6 +530,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 +562,36 @@ 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)) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (pathname-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)) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (pathname-coding-system nnmail-pathname-coding-system)) + ;; 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 (point-min) (point-max) file nil 'quietly)) + (write-region-as-coding-system + coding-system (point-min) (point-max) file nil 'quietly)) (defun gnus-delete-file (file) "Delete FILE if it exists." @@ -564,7 +610,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))))) @@ -678,7 +724,8 @@ with potentially long computations." (set-buffer file-buffer) (rmail-insert-rmail-file-header) (let ((require-final-newline nil)) - (gnus-write-buffer filename))) + (gnus-write-buffer-as-coding-system + nnheader-text-coding-system filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) (set-buffer tmpbuf) @@ -688,7 +735,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) - (mm-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 +776,8 @@ with potentially long computations." (save-excursion (set-buffer file-buffer) (let ((require-final-newline nil)) - (gnus-write-buffer filename))) + (gnus-write-buffer-as-coding-system + nnheader-text-coding-system filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) (set-buffer tmpbuf) @@ -756,7 +804,8 @@ with potentially long computations." (insert "\n")) (insert "\n")) (goto-char (point-max)) - (mm-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)) @@ -802,7 +851,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)) @@ -850,16 +900,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." @@ -940,19 +1004,41 @@ 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 - (symbol-name sym) - (gnus-group-real-name (symbol-name sym))) - (cdr (symbol-value sym)) - (car (symbol-value sym)))))) - hashtb))) + (let ((output-coding-system nnmail-active-file-coding-system) + (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)))) (provide 'gnus-util)