X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnnheader.el;h=f36059b4e43897b8103641fc87cfdfb8e4a034cc;hb=ede88a05dcfa43327283432647c47e732f032a15;hp=140ab7b3f293d5f98c5d29c41a067fe9e69d53a8;hpb=cbd664a763e4be0fb6a79a51b3bb749e491bff46;p=elisp%2Fgnus.git- diff --git a/lisp/nnheader.el b/lisp/nnheader.el index 140ab7b..f36059b 100644 --- a/lisp/nnheader.el +++ b/lisp/nnheader.el @@ -1,7 +1,7 @@ ;;; nnheader.el --- header access macros for Semi-gnus and its backends ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000, 2001 +;; 1997, 1998, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA @@ -49,7 +49,8 @@ (eval-and-compile (autoload 'gnus-sorted-intersection "gnus-range") (autoload 'gnus-intersection "gnus-range") - (autoload 'gnus-sorted-complement "gnus-range")) + (autoload 'gnus-sorted-complement "gnus-range") + (autoload 'gnus-sorted-difference "gnus-range")) (defcustom gnus-verbose-backends 7 "Integer that says how verbose the Gnus backends should be. @@ -78,7 +79,18 @@ Integer values will in effect be rounded up to the nearest multiple of (defvar nnheader-head-chop-length 2048 "*Length of each read operation when trying to fetch HEAD headers.") -(defvar nnheader-file-name-translation-alist nil +(defvar nnheader-file-name-translation-alist + (let ((case-fold-search t)) + (cond + ((string-match "windows-nt\\|os/2\\|emx\\|cygwin" + (symbol-name system-type)) + (append (mapcar (lambda (c) (cons c ?_)) + '(?: ?* ?\" ?< ?> ??)) + (if (string-match "windows-nt\\|cygwin" + (symbol-name system-type)) + nil + '((?+ . ?-))))) + (t nil))) "*Alist that says how to translate characters in file names. For instance, if \":\" is invalid as a file character in file names on your system, you could say something like: @@ -96,6 +108,18 @@ This variable is a substitute for `mm-text-coding-system'.") "Text coding system for write. This variable is a substitute for `mm-text-coding-system-for-write'.") +(defvar nnheader-auto-save-coding-system + (cond + ((boundp 'MULE) '*junet*) + ((not (fboundp 'find-coding-system)) nil) + ((find-coding-system 'emacs-mule) + (if (memq system-type '(windows-nt ms-dos ms-windows)) + 'emacs-mule-dos 'emacs-mule)) + ((find-coding-system 'escape-quoted) 'escape-quoted) + ((find-coding-system 'no-conversion) 'no-conversion) + (t nil)) + "Coding system of auto save file.") + (eval-and-compile (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") @@ -103,6 +127,360 @@ This variable is a substitute for `mm-text-coding-system-for-write'.") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-buffer-live-p "gnus-util")) +;; mm-util stuff. +(unless (featurep 'mm-util) + ;; Should keep track of `mm-image-load-path' in mm-util.el. + (defun nnheader-image-load-path (&optional package) + (let (dir result) + (dolist (path load-path (nreverse result)) + (if (file-directory-p + (setq dir (concat (file-name-directory + (directory-file-name path)) + "etc/" (or package "gnus/")))) + (push dir result)) + (push path result)))) + (defalias 'mm-image-load-path 'nnheader-image-load-path) + + ;; Should keep track of `mm-read-coding-system' in mm-util.el. + (defalias 'mm-read-coding-system + (if (or (and (featurep 'xemacs) + (<= (string-to-number emacs-version) 21.1)) + (boundp 'MULE)) + (lambda (prompt &optional default-coding-system) + (read-coding-system prompt)) + 'read-coding-system)) + + ;; Should keep track of `mm-%s' in mm-util.el. + (defalias 'mm-multibyte-string-p + (if (fboundp 'multibyte-string-p) + 'multibyte-string-p + 'ignore)) + (defalias 'mm-encode-coding-string 'encode-coding-string) + (defalias 'mm-decode-coding-string 'decode-coding-string) + + ;; Should keep track of `mm-detect-coding-region' in mm-util.el. + (defun nnheader-detect-coding-region (start end) + "Like 'detect-coding-region' except returning the best one." + (let ((coding-systems + (static-if (boundp 'MULE) + (code-detect-region (point) (point-max)) + (detect-coding-region (point) (point-max))))) + (or (car-safe coding-systems) + coding-systems))) + (defalias 'mm-detect-coding-region 'nnheader-detect-coding-region) + + ;; Should keep track of `mm-detect-mime-charset-region' in mm-util.el. + (defun nnheader-detect-mime-charset-region (start end) + "Detect MIME charset of the text in the region between START and END." + (coding-system-to-mime-charset + (nnheader-detect-coding-region start end))) + (defalias 'mm-detect-mime-charset-region + 'nnheader-detect-mime-charset-region) + + ;; Should keep track of `mm-with-unibyte-buffer' in mm-util.el. + (defmacro nnheader-with-unibyte-buffer (&rest forms) + "Create a temporary buffer, and evaluate FORMS there like `progn'. +Use unibyte mode for this." + `(let (default-enable-multibyte-characters default-mc-flag) + (with-temp-buffer ,@forms))) + (put 'nnheader-with-unibyte-buffer 'lisp-indent-function 0) + (put 'nnheader-with-unibyte-buffer 'edebug-form-spec '(body)) + (put 'mm-with-unibyte-buffer 'lisp-indent-function 0) + (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) + (defalias 'mm-with-unibyte-buffer 'nnheader-with-unibyte-buffer) + + ;; Should keep track of `mm-with-unibyte-current-buffer' in mm-util.el. + (defmacro nnheader-with-unibyte-current-buffer (&rest forms) + "Evaluate FORMS with current current buffer temporarily made unibyte. +Also bind `default-enable-multibyte-characters' to nil. +Equivalent to `progn' in XEmacs" + (let ((multibyte (make-symbol "multibyte")) + (buffer (make-symbol "buffer"))) + (cond ((featurep 'xemacs) + `(let (default-enable-multibyte-characters) + ,@forms)) + ((boundp 'MULE) + `(let ((,multibyte mc-flag) + (,buffer (current-buffer))) + (unwind-protect + (let (default-enable-multibyte-characters default-mc-flag) + (setq mc-flag nil) + ,@forms) + (set-buffer ,buffer) + (setq mc-flag ,multibyte)))) + (t + `(let ((,multibyte enable-multibyte-characters) + (,buffer (current-buffer))) + (unwind-protect + (let (default-enable-multibyte-characters) + (set-buffer-multibyte nil) + ,@forms) + (set-buffer ,buffer) + (set-buffer-multibyte ,multibyte))))))) + (put 'nnheader-with-unibyte-current-buffer 'lisp-indent-function 0) + (put 'nnheader-with-unibyte-current-buffer 'edebug-form-spec '(body)) + (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0) + (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body)) + (defalias 'mm-with-unibyte-current-buffer + 'nnheader-with-unibyte-current-buffer) + + ;; Should keep track of `mm-with-unibyte' in mm-util.el. + (defmacro nnheader-with-unibyte (&rest forms) + "Eval the FORMS with the default value of `enable-multibyte-characters' +nil, ." + `(let (default-enable-multibyte-characters) + ,@forms)) + (put 'nnheader-with-unibyte 'lisp-indent-function 0) + (put 'nnheader-with-unibyte 'edebug-form-spec '(body)) + (put 'mm-with-unibyte 'lisp-indent-function 0) + (put 'mm-with-unibyte 'edebug-form-spec '(body)) + (defalias 'mm-with-unibyte 'nnheader-with-unibyte) + + ;; Should keep track of `mm-guess-mime-charset' in mm-util.el. + (defun nnheader-guess-mime-charset () + "Guess the default MIME charset from the language environment." + (let ((language-info + (and (boundp 'current-language-environment) + (assoc current-language-environment + language-info-alist))) + item) + (cond + ((null language-info) + 'iso-8859-1) + ((setq item + (cadr + (or (assq 'coding-priority language-info) + (assq 'coding-system language-info)))) + (if (fboundp 'coding-system-get) + (or (coding-system-get item 'mime-charset) + item) + item)) + ((setq item (car (last (assq 'charset language-info)))) + (if (eq item 'ascii) + 'iso-8859-1 + (charsets-to-mime-charset (list item)))) + (t + 'iso-8859-1)))) + (defalias 'mm-guess-mime-charset 'nnheader-guess-mime-charset) + + (defalias 'mm-char-int 'char-int) + + ;; Should keep track of the same alias in mm-util.el. + (defalias 'mm-multibyte-p + (static-cond ((and (featurep 'xemacs) (featurep 'mule)) + (lambda nil t)) + ((featurep 'xemacs) + (lambda nil nil)) + ((boundp 'MULE) + (lambda nil mc-flag)) + (t + (lambda nil enable-multibyte-characters)))) + + ;; Should keep track of the same alias in mm-util.el. + (defalias 'mm-make-temp-file + (if (fboundp 'make-temp-file) + 'make-temp-file + (lambda (prefix &optional dir-flag) + (let ((file (expand-file-name + (make-temp-name prefix) + (if (fboundp 'temp-directory) + (temp-directory) + temporary-file-directory)))) + (if dir-flag + (make-directory file)) + file))))) + +;; mail-parse stuff. +(unless (featurep 'mail-parse) + ;; Should keep track of `rfc2047-narrow-to-field' in rfc2047.el. + (defun-maybe std11-narrow-to-field () + "Narrow the buffer to the header on the current line." + (forward-line 0) + (narrow-to-region (point) + (progn + (std11-field-end) + (when (eolp) (forward-line 1)) + (point))) + (goto-char (point-min))) + (defalias 'mail-header-narrow-to-field 'std11-narrow-to-field) + + ;; Should keep track of `ietf-drums-narrow-to-header' in ietf-drums.el. + (defun mail-narrow-to-head () + "Narrow to the header section in the current buffer." + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) + (point-max))) + (goto-char (point-min))) + + ;; Should keep track of `rfc2047-fold-region' in rfc2047.el. + (defun-maybe std11-fold-region (b e) + "Fold long lines in region B to E." + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (let ((break nil) + (qword-break nil) + (first t) + (bol (save-restriction + (widen) + (gnus-point-at-bol)))) + (while (not (eobp)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) + (goto-char (or break qword-break)) + (setq break nil + qword-break nil) + (if (looking-at "[ \t]") + (insert "\n") + (insert "\n ")) + (setq bol (1- (point))) + ;; Don't break before the first non-LWSP characters. + (skip-chars-forward " \t") + (unless (eobp) + (forward-char 1))) + (cond + ((eq (char-after) ?\n) + (forward-char 1) + (setq bol (point) + break nil + qword-break nil) + (skip-chars-forward " \t") + (unless (or (eobp) (eq (char-after) ?\n)) + (forward-char 1))) + ((eq (char-after) ?\r) + (forward-char 1)) + ((memq (char-after) '(? ?\t)) + (skip-chars-forward " \t") + (if first + ;; Don't break just after the header name. + (setq first nil) + (setq break (1- (point))))) + ((not break) + (if (not (looking-at "=\\?[^=]")) + (if (eq (char-after) ?=) + (forward-char 1) + (skip-chars-forward "^ \t\n\r=")) + (setq qword-break (point)) + (skip-chars-forward "^ \t\n\r"))) + (t + (skip-chars-forward "^ \t\n\r")))) + (when (and (or break qword-break) + (> (- (point) bol) 76)) + (goto-char (or break qword-break)) + (setq break nil + qword-break nil) + (if (looking-at "[ \t]") + (insert "\n") + (insert "\n ")) + (setq bol (1- (point))) + ;; Don't break before the first non-LWSP characters. + (skip-chars-forward " \t") + (unless (eobp) + (forward-char 1)))))) + + ;; Should keep track of `rfc2047-fold-field' in rfc2047.el. + (defun-maybe std11-fold-field () + "Fold the current line." + (save-excursion + (save-restriction + (std11-narrow-to-field) + (std11-fold-region (point-min) (point-max))))) + + (defalias 'mail-header-fold-field 'std11-fold-field) + + ;; Should keep track of `rfc2047-unfold-region' in rfc2047.el. + (defun-maybe std11-unfold-region (b e) + "Unfold lines in region B to E." + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (let ((bol (save-restriction + (widen) + (gnus-point-at-bol))) + (eol (gnus-point-at-eol))) + (forward-line 1) + (while (not (eobp)) + (if (and (looking-at "[ \t]") + (< (- (gnus-point-at-eol) bol) 76)) + (delete-region eol (progn + (goto-char eol) + (skip-chars-forward "\r\n") + (point))) + (setq bol (gnus-point-at-bol))) + (setq eol (gnus-point-at-eol)) + (forward-line 1))))) + + ;; Should keep track of `rfc2047-unfold-field' in rfc2047.el. + (defun-maybe std11-unfold-field () + "Fold the current line." + (save-excursion + (save-restriction + (std11-narrow-to-field) + (std11-unfold-region (point-min) (point-max))))) + + (defalias 'mail-header-unfold-field 'std11-unfold-field) + + ;; This is the original function in T-gnus. + (defun-maybe std11-extract-addresses-components (string) + "Extract a list of full name and canonical address from STRING. Each +element looks like a list of the form (FULL-NAME CANONICAL-ADDRESS). +If no name can be extracted, FULL-NAME will be nil." + (when string + (let (addresses) + (dolist (structure (std11-parse-addresses-string + (std11-unfold-string string)) + addresses) + (push (list (std11-full-name-string structure) + (std11-address-string structure)) + addresses)) + (nreverse addresses)))) + + ;; Should keep track of `ietf-drums-parse-addresses' in ietf-drums.el. + (defun mail-header-parse-addresses (string) + "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs." + (mapcar (function + (lambda (components) + (cons (nth 1 components) (car components)))) + (std11-extract-addresses-components string))) + + ;; Should keep track of `rfc2047-field-value' in rfc2047.el. + (defun std11-field-value (&optional dont-include-last-newline) + "Return the value of the field at point. If the optional argument is +given, the return value will not contain the last newline." + (let ((begin (point)) + (inhibit-point-motion-hooks t) + start value) + (beginning-of-line) + (unless (eobp) + (while (and (memq (char-after) '(?\t ?\ )) + (zerop (forward-line -1)))) + (when (looking-at "[^\t\n ]+:[\t\n ]+") + (goto-char (setq start (match-end 0))) + (forward-line 1) + (while (and (memq (char-after) '(?\t ?\ )) + (zerop (forward-line 1)))) + (when dont-include-last-newline + (skip-chars-backward "\t\n " start)) + (setq value (buffer-substring start (point))))) + (goto-char begin) + value)) + + (defalias 'mail-header-field-value 'std11-field-value)) + +;; ietf-drums stuff. +(unless (featurep 'ietf-drums) + ;; Should keep track of `ietf-drums-unfold-fws' in ietf-drums.el. + (defun nnheader-unfold-fws () + "Unfold folding white space in the current buffer." + (goto-char (point-min)) + (while (re-search-forward "[ \t]*\n[ \t]+" nil t) + (replace-match " " t t)) + (goto-char (point-min))) + + (defalias 'ietf-drums-unfold-fws 'nnheader-unfold-fws)) + ;;; Header access macros. ;; These macros may look very much like the ones in GNUS 4.1. They @@ -222,6 +600,11 @@ This variable is a substitute for `mm-text-coding-system-for-write'.") ;; Parsing headers and NOV lines. +(defsubst nnheader-remove-cr-followed-by-lf () + (goto-char (point-max)) + (while (search-backward "\r\n" nil t) + (delete-char 1))) + (defsubst nnheader-header-value () (let ((pt (point))) (prog2 @@ -229,116 +612,126 @@ This variable is a substitute for `mm-text-coding-system-for-write'.") (buffer-substring (point) (std11-field-end)) (goto-char pt)))) -(defun nnheader-parse-head (&optional naked) +(defun nnheader-parse-naked-head (&optional number) + ;; This function unfolds continuation lines in this buffer + ;; destructively. When this side effect is unwanted, use + ;; `nnheader-parse-head' instead of this function. (let ((case-fold-search t) - (cur (current-buffer)) (buffer-read-only nil) - in-reply-to lines p ref) - (goto-char (point-min)) - (when naked - (insert "\n")) - ;; Search to the beginning of the next header. Error messages - ;; do not begin with 2 or 3. + (cur (current-buffer)) + (p (point-min)) + in-reply-to lines ref) + (nnheader-remove-cr-followed-by-lf) + (ietf-drums-unfold-fws) + (subst-char-in-region (point-min) (point-max) ?\t ? ) + (goto-char p) + (insert "\n") (prog1 - (when (or naked (re-search-forward "^[23][0-9]+ " nil t)) - ;; This implementation of this function, with nine - ;; search-forwards instead of the one re-search-forward and - ;; a case (which basically was the old function) is actually - ;; about twice as fast, even though it looks messier. You - ;; can't have everything, I guess. Speed and elegance - ;; don't always go hand in hand. - (make-full-mail-header - ;; Number. - (if naked - (progn - (setq p (point-min)) - 0) - (prog1 - (read cur) - (end-of-line) - (setq p (point)) - (narrow-to-region (point) - (or (and (search-forward "\n.\n" nil t) - (- (point) 2)) - (point))))) - ;; Subject. - (progn - (goto-char p) - (if (search-forward "\nsubject:" nil t) - (nnheader-header-value) "(none)")) - ;; From. - (progn - (goto-char p) - (if (search-forward "\nfrom:" nil t) - (nnheader-header-value) "(nobody)")) - ;; Date. - (progn - (goto-char p) - (if (search-forward "\ndate:" nil t) - (nnheader-header-value) "")) - ;; Message-ID. - (progn - (goto-char p) - (if (search-forward "\nmessage-id:" nil t) - (buffer-substring - (1- (or (search-forward "<" (gnus-point-at-eol) t) - (point))) - (or (search-forward ">" (gnus-point-at-eol) t) (point))) - ;; If there was no message-id, we just fake one to make - ;; subsequent routines simpler. - (nnheader-generate-fake-message-id))) - ;; References. - (progn - (goto-char p) - (if (search-forward "\nreferences:" nil t) - (nnheader-header-value) - ;; Get the references from the in-reply-to header if there - ;; were no references and the in-reply-to header looks - ;; promising. - (if (and (search-forward "\nin-reply-to:" nil t) - (setq in-reply-to (nnheader-header-value)) - (string-match "<[^\n>]+>" in-reply-to)) - (let (ref2) - (setq ref (substring in-reply-to (match-beginning 0) - (match-end 0))) - (while (string-match "<[^\n>]+>" - in-reply-to (match-end 0)) - (setq ref2 (substring in-reply-to (match-beginning 0) - (match-end 0))) - (when (> (length ref2) (length ref)) - (setq ref ref2))) - ref) - nil))) - ;; Chars. - 0 - ;; Lines. - (progn - (goto-char p) - (if (search-forward "\nlines: " nil t) - (if (numberp (setq lines (read cur))) - lines 0) - 0)) - ;; Xref. - (progn - (goto-char p) - (and (search-forward "\nxref:" nil t) - (nnheader-header-value))) - - ;; Extra. - (when nnmail-extra-headers - (let ((extra nnmail-extra-headers) - out) - (while extra - (goto-char p) - (when (search-forward - (concat "\n" (symbol-name (car extra)) ":") nil t) - (push (cons (car extra) (nnheader-header-value)) - out)) - (pop extra)) - out)))) - (when naked - (goto-char (point-min)) - (delete-char 1))))) + ;; This implementation of this function, with nine + ;; search-forwards instead of the one re-search-forward and a + ;; case (which basically was the old function) is actually + ;; about twice as fast, even though it looks messier. You + ;; can't have everything, I guess. Speed and elegance don't + ;; always go hand in hand. + (make-full-mail-header + ;; Number. + (or number 0) + ;; Subject. + (progn + (goto-char p) + (if (search-forward "\nsubject:" nil t) + (nnheader-header-value) "(none)")) + ;; From. + (progn + (goto-char p) + (if (search-forward "\nfrom:" nil t) + (nnheader-header-value) "(nobody)")) + ;; Date. + (progn + (goto-char p) + (if (search-forward "\ndate:" nil t) + (nnheader-header-value) "")) + ;; Message-ID. + (progn + (goto-char p) + (if (search-forward "\nmessage-id:" nil t) + (buffer-substring + (1- (or (search-forward "<" (gnus-point-at-eol) t) + (point))) + (or (search-forward ">" (gnus-point-at-eol) t) (point))) + ;; If there was no message-id, we just fake one to make + ;; subsequent routines simpler. + (nnheader-generate-fake-message-id))) + ;; References. + (progn + (goto-char p) + (if (search-forward "\nreferences:" nil t) + (nnheader-header-value) + ;; Get the references from the in-reply-to header if + ;; there were no references and the in-reply-to header + ;; looks promising. + (if (and (search-forward "\nin-reply-to:" nil t) + (setq in-reply-to (nnheader-header-value)) + (string-match "<[^\n>]+>" in-reply-to)) + (let (ref2) + (setq ref (substring in-reply-to (match-beginning 0) + (match-end 0))) + (while (string-match "<[^\n>]+>" + in-reply-to (match-end 0)) + (setq ref2 (substring in-reply-to (match-beginning 0) + (match-end 0))) + (when (> (length ref2) (length ref)) + (setq ref ref2))) + ref) + nil))) + ;; Chars. + 0 + ;; Lines. + (progn + (goto-char p) + (if (search-forward "\nlines: " nil t) + (if (numberp (setq lines (read cur))) + lines 0) + 0)) + ;; Xref. + (progn + (goto-char p) + (and (search-forward "\nxref:" nil t) + (nnheader-header-value))) + ;; Extra. + (when nnmail-extra-headers + (let ((extra nnmail-extra-headers) + out) + (while extra + (goto-char p) + (when (search-forward + (concat "\n" (symbol-name (car extra)) ":") nil t) + (push (cons (car extra) (nnheader-header-value)) + out)) + (pop extra)) + out))) + (goto-char p) + (delete-char 1)))) + +(defun nnheader-parse-head (&optional naked) + (let ((cur (current-buffer)) num beg end) + (when (if naked + (setq num 0 + beg (point-min) + end (point-max)) + (goto-char (point-min)) + ;; Search to the beginning of the next header. Error + ;; messages do not begin with 2 or 3. + (when (re-search-forward "^[23][0-9]+ " nil t) + (end-of-line) + (setq num (read cur) + beg (point) + end (if (search-forward "\n.\n" nil t) + (- (point) 2) + (point))))) + (with-temp-buffer + (insert-buffer-substring cur beg end) + (nnheader-parse-naked-head num))))) (defmacro nnheader-nov-skip-field () '(search-forward "\t" eol 'move)) @@ -424,6 +817,22 @@ This variable is a substitute for `mm-text-coding-system-for-write'.") (delete-char 1)) (forward-line 1))) +(defun nnheader-parse-overview-file (file) + "Parse FILE and return a list of headers." + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (let (headers) + (while (not (eobp)) + (push (nnheader-parse-nov) headers) + (forward-line 1)) + (nreverse headers)))) + +(defun nnheader-write-overview-file (file headers) + "Write HEADERS to FILE." + (with-temp-file file + (mapcar 'nnheader-insert-nov headers))) + (defun nnheader-insert-header (header) (insert "Subject: " (or (mail-header-subject header) "(none)") "\n" @@ -797,6 +1206,12 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')." (point-max))) (goto-char (point-min))) +(defun nnheader-remove-body () + "Remove the body from an article in this current buffer." + (goto-char (point-min)) + (when (re-search-forward "\n\r?\n" nil t) + (delete-region (point) (point-max)))) + (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." (set-buffer (get-buffer-create name)) @@ -1028,9 +1443,7 @@ without formatting." (defun nnheader-ms-strip-cr () "Strip ^M from the end of all lines." (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\r$" nil t) - (delete-backward-char 1)))) + (nnheader-remove-cr-followed-by-lf))) (defun nnheader-file-size (file) "Return the file size of FILE or 0." @@ -1088,6 +1501,25 @@ find-file-hooks, etc. (insert-file-contents-as-coding-system nnheader-file-coding-system filename visit beg end replace))) +(defun nnheader-insert-nov-file (file first) + (let ((size (nth 7 (file-attributes file))) + (cutoff (* 32 1024))) + (if (< size cutoff) + ;; If the file is small, we just load it. + (nnheader-insert-file-contents file) + ;; We start on the assumption that FIRST is pretty recent. If + ;; not, we just insert the rest of the file as well. + (let (current) + (nnheader-insert-file-contents file nil (- size cutoff) size) + (goto-char (point-min)) + (delete-region (point) (or (search-forward "\n" nil 'move) (point))) + (setq current (ignore-errors (read (current-buffer)))) + (if (and (numberp current) + (< current first)) + t + (delete-region (point-min) (point-max)) + (nnheader-insert-file-contents file)))))) + (defun nnheader-find-file-noselect (&rest args) (let ((format-alist nil) (auto-mode-alist (nnheader-auto-mode-alist)) @@ -1183,197 +1615,12 @@ find-file-hooks, etc. (message "%s(Y/n) Yes" prompt) t))) -;; mm- stuff. -(unless (featurep 'mm-util) - (defun nnheader-image-load-path (&optional package) - (let (dir result) - (dolist (path load-path (nreverse result)) - (if (file-directory-p - (setq dir (concat (file-name-directory - (directory-file-name path)) - "etc/" (or package "gnus/")))) - (push dir result)) - (push path result)))) - (defalias 'mm-image-load-path 'nnheader-image-load-path) - - (defalias 'mm-read-coding-system - (if (or (and (featurep 'xemacs) - (<= (string-to-number emacs-version) 21.1)) - (boundp 'MULE)) - (lambda (prompt &optional default-coding-system) - (read-coding-system prompt)) - 'read-coding-system)) - - (defalias 'mm-multibyte-string-p - (if (fboundp 'multibyte-string-p) - 'multibyte-string-p - 'ignore)) - - (defun nnheader-detect-coding-region (start end) - "Like 'detect-coding-region' except returning the best one." - (let ((coding-systems - (static-if (boundp 'MULE) - (code-detect-region (point) (point-max)) - (detect-coding-region (point) (point-max))))) - (or (car-safe coding-systems) - coding-systems))) - (defalias 'mm-detect-coding-region 'nnheader-detect-coding-region) - - (defun nnheader-detect-mime-charset-region (start end) - "Detect MIME charset of the text in the region between START and END." - (coding-system-to-mime-charset - (nnheader-detect-coding-region start end))) - (defalias 'mm-detect-mime-charset-region - 'nnheader-detect-mime-charset-region) - - (defmacro nnheader-with-unibyte-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -Use unibyte mode for this." - `(let (default-enable-multibyte-characters mc-flag) - (with-temp-buffer ,@forms))) - (put 'nnheader-with-unibyte-buffer 'lisp-indent-function 0) - (put 'nnheader-with-unibyte-buffer 'edebug-form-spec '(body)) - (put 'mm-with-unibyte-buffer 'lisp-indent-function 0) - (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body)) - (defalias 'mm-with-unibyte-buffer 'nnheader-with-unibyte-buffer)) - -;; mail-parse stuff. -(unless (featurep 'mail-parse) - (defun-maybe std11-narrow-to-field () - "Narrow the buffer to the header on the current line." - (forward-line 0) - (narrow-to-region (point) - (progn - (std11-field-end) - (when (eolp) (forward-line 1)) - (point))) - (goto-char (point-min))) - - (defalias 'mail-header-narrow-to-field 'std11-narrow-to-field) - - (defun mail-narrow-to-head () - "Narrow to the header section in the current buffer." - (narrow-to-region - (goto-char (point-min)) - (if (re-search-forward "^\r?$" nil 1) - (match-beginning 0) - (point-max))) - (goto-char (point-min))) - - (defun-maybe std11-fold-region (b e) - "Fold long lines in region B to E." - (save-restriction - (narrow-to-region b e) - (goto-char (point-min)) - (let ((break nil) - (qword-break nil) - (first t) - (bol (save-restriction - (widen) - (gnus-point-at-bol)))) - (while (not (eobp)) - (when (and (or break qword-break) - (> (- (point) bol) 76)) - (goto-char (or break qword-break)) - (setq break nil - qword-break nil) - (if (looking-at "[ \t]") - (insert "\n") - (insert "\n ")) - (setq bol (1- (point))) - ;; Don't break before the first non-LWSP characters. - (skip-chars-forward " \t") - (unless (eobp) - (forward-char 1))) - (cond - ((eq (char-after) ?\n) - (forward-char 1) - (setq bol (point) - break nil - qword-break nil) - (skip-chars-forward " \t") - (unless (or (eobp) (eq (char-after) ?\n)) - (forward-char 1))) - ((eq (char-after) ?\r) - (forward-char 1)) - ((memq (char-after) '(? ?\t)) - (skip-chars-forward " \t") - (if first - ;; Don't break just after the header name. - (setq first nil) - (setq break (1- (point))))) - ((not break) - (if (not (looking-at "=\\?[^=]")) - (if (eq (char-after) ?=) - (forward-char 1) - (skip-chars-forward "^ \t\n\r=")) - (setq qword-break (point)) - (skip-chars-forward "^ \t\n\r"))) - (t - (skip-chars-forward "^ \t\n\r")))) - (when (and (or break qword-break) - (> (- (point) bol) 76)) - (goto-char (or break qword-break)) - (setq break nil - qword-break nil) - (if (looking-at "[ \t]") - (insert "\n") - (insert "\n ")) - (setq bol (1- (point))) - ;; Don't break before the first non-LWSP characters. - (skip-chars-forward " \t") - (unless (eobp) - (forward-char 1)))))) - - (defun-maybe std11-fold-field () - "Fold the current line." - (save-excursion - (save-restriction - (std11-narrow-to-field) - (std11-fold-region (point-min) (point-max))))) - - (defalias 'mail-header-fold-field 'std11-fold-field) - - (defun-maybe std11-extract-addresses-components (string) - "Extract a list of full name and canonical address from STRING. Each -element looks like a list of the form (FULL-NAME CANONICAL-ADDRESS). -If no name can be extracted, FULL-NAME will be nil." - (when string - (mapcar (function - (lambda (structure) - (list (std11-full-name-string structure) - (std11-address-string structure)))) - (std11-parse-addresses-string (std11-unfold-string string))))) - - (defun mail-header-parse-addresses (string) - "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs." - (mapcar (function - (lambda (components) - (cons (nth 1 components) (car components)))) - (std11-extract-addresses-components string))) - - (defun-maybe std11-field-value (&optional dont-include-last-newline) - "Return the value of the field at point. If the optional argument is -given, the return value will not contain the last newline." - (let ((begin (point)) - (inhibit-point-motion-hooks t) - start value) - (beginning-of-line) - (unless (eobp) - (while (and (memq (char-after) '(?\t ?\ )) - (zerop (forward-line -1)))) - (when (looking-at "[^\t\n ]+:[\t\n ]+") - (goto-char (setq start (match-end 0))) - (forward-line 1) - (while (and (memq (char-after) '(?\t ?\ )) - (zerop (forward-line 1)))) - (when dont-include-last-newline - (skip-chars-backward "\t\n " start)) - (setq value (buffer-substring start (point))))) - (goto-char begin) - value)) - - (defalias 'mail-header-field-value 'std11-field-value)) +(defun-maybe shell-command-to-string (command) + "Execute shell command COMMAND and return its output as a string." + (with-output-to-string + (with-current-buffer + standard-output + (call-process shell-file-name nil t nil shell-command-switch command)))) (when (featurep 'xemacs) (require 'nnheaderxm))