X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnnheader.el;h=c777023046653472d5e0e7fcf9138bd51636c52f;hb=4c4ee2ed7b5f6c14942c73a92ff0a761b78fe2dd;hp=37dc400e217d734c1bc56017b7ada55ca5314ef7;hpb=dde2712bedc3af46c63d6249660f76b6d66a975c;p=elisp%2Fgnus.git- diff --git a/lisp/nnheader.el b/lisp/nnheader.el index 37dc400..c777023 100644 --- a/lisp/nnheader.el +++ b/lisp/nnheader.el @@ -1,5 +1,8 @@ ;;; nnheader.el --- header access macros for Semi-gnus and its backends -;; Copyright (C) 1987-1990,1993-1999 Free Software Foundation, Inc. + +;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996, +;; 1997, 1998, 2000 +;; Free Software Foundation, Inc. ;; Author: Masanobu UMEDA ;; Lars Magne Ingebrigtsen @@ -26,20 +29,10 @@ ;;; Commentary: -;; These macros may look very much like the ones in GNUS 4.1. They -;; are, in a way, but you should note that the indices they use have -;; been changed from the internal GNUS format to the NOV format. The -;; makes it possible to read headers from XOVER much faster. -;; -;; The format of a header is now: -;; [number subject from date id references chars lines xref] -;; -;; (That last entry is defined as "misc" in the NOV format, but Gnus -;; uses it for xrefs.) - ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile (require 'static)) (require 'mail-utils) (require 'mime) @@ -57,17 +50,40 @@ on your system, you could say something like: \(setq nnheader-file-name-translation-alist '((?: . ?_)))") +(defvar nnheader-text-coding-system + (if (memq system-type '(windows-nt ms-dos ms-windows)) + 'raw-text-dos + 'raw-text) + "Text-safe coding system (For removing ^M). +This variable is a substitute for `mm-text-coding-system'.") + +(defvar nnheader-text-coding-system-for-write nil + "Text coding system for write. +This variable is a substitute for `mm-text-coding-system-for-write'.") + (eval-and-compile - (autoload 'nnmail-message-id "nnmail") - (autoload 'mail-position-on-field "sendmail") - (autoload 'message-remove-header "message") - (autoload 'cancel-function-timers "timers") - (autoload 'gnus-point-at-eol "gnus-util") - (autoload 'gnus-delete-line "gnus-util") - (autoload 'gnus-buffer-live-p "gnus-util")) + (autoload 'nnmail-message-id "nnmail") + (autoload 'mail-position-on-field "sendmail") + (autoload 'message-remove-header "message") + (autoload 'gnus-point-at-eol "gnus-util") + (autoload 'gnus-delete-line "gnus-util") + (autoload 'gnus-buffer-live-p "gnus-util")) ;;; Header access macros. +;; These macros may look very much like the ones in GNUS 4.1. They +;; are, in a way, but you should note that the indices they use have +;; been changed from the internal GNUS format to the NOV format. The +;; makes it possible to read headers from XOVER much faster. +;; +;; The format of a header is now: +;; [number subject from date id references chars lines xref extra] +;; +;; (That next-to-last entry is defined as "misc" in the NOV format, +;; but Gnus uses it for xrefs.) + +(require 'mmgnus) + (defmacro mail-header-number (header) "Return article number in HEADER." `(mime-entity-location-internal ,header)) @@ -76,86 +92,85 @@ on your system, you could say something like: "Set article number of HEADER to NUMBER." `(mime-entity-set-location-internal ,header ,number)) -(defalias 'mail-header-subject 'mime-entity-decoded-subject-internal) -(defalias 'mail-header-set-subject 'mime-entity-set-decoded-subject-internal) +(defalias 'mail-header-subject 'mime-gnus-entity-subject-internal) +(defalias 'mail-header-set-subject 'mime-gnus-entity-set-subject-internal) -(defalias 'mail-header-from 'mime-entity-decoded-from-internal) -(defalias 'mail-header-set-from 'mime-entity-set-decoded-from-internal) +(defalias 'mail-header-from 'mime-gnus-entity-from-internal) +(defalias 'mail-header-set-from 'mime-gnus-entity-set-from-internal) -(defalias 'mail-header-date 'mime-entity-date-internal) -(defalias 'mail-header-set-date 'mime-entity-set-date-internal) +(defalias 'mail-header-date 'mime-gnus-entity-date-internal) +(defalias 'mail-header-set-date 'mime-gnus-entity-set-date-internal) -(defalias 'mail-header-message-id 'mime-entity-message-id-internal) -(defalias 'mail-header-id 'mime-entity-message-id-internal) -(defalias 'mail-header-set-message-id 'mime-entity-set-message-id-internal) -(defalias 'mail-header-set-id 'mime-entity-set-message-id-internal) +(defalias 'mail-header-message-id 'mime-gnus-entity-id-internal) +(defalias 'mail-header-id 'mime-gnus-entity-id-internal) +(defalias 'mail-header-set-message-id 'mime-gnus-entity-set-id-internal) +(defalias 'mail-header-set-id 'mime-gnus-entity-set-id-internal) -(defalias 'mail-header-references 'mime-entity-references-internal) -(defalias 'mail-header-set-references 'mime-entity-set-references-internal) +(defalias 'mail-header-references 'mime-gnus-entity-references-internal) +(defalias 'mail-header-set-references + 'mime-gnus-entity-set-references-internal) -(defalias 'mail-header-chars 'mime-entity-chars-internal) -(defalias 'mail-header-set-chars 'mime-entity-set-chars-internal) +(defalias 'mail-header-chars 'mime-gnus-entity-chars-internal) +(defalias 'mail-header-set-chars 'mime-gnus-entity-set-chars-internal) -(defalias 'mail-header-lines 'mime-entity-lines-internal) -(defalias 'mail-header-set-lines 'mime-entity-set-lines-internal) +(defalias 'mail-header-lines 'mime-gnus-entity-lines-internal) +(defalias 'mail-header-set-lines 'mime-gnus-entity-set-lines-internal) -(defalias 'mail-header-xref 'mime-entity-xref-internal) -(defalias 'mail-header-set-xref 'mime-entity-set-xref-internal) +(defalias 'mail-header-xref 'mime-gnus-entity-xref-internal) +(defalias 'mail-header-set-xref 'mime-gnus-entity-set-xref-internal) (defalias 'nnheader-decode-subject (mime-find-field-decoder 'Subject 'nov)) (defalias 'nnheader-decode-from (mime-find-field-decoder 'From 'nov)) -(defalias 'mail-header-extra 'ignore) -(defalias 'mail-header-set-extra 'ignore) +(defalias 'mail-header-extra 'mime-gnus-entity-extra-internal) +(defalias 'mail-header-set-extra 'mime-gnus-entity-set-extra-internal) -(defsubst nnheader-decode-field-body (field-body field-name - &optional mode max-column) +(defun nnheader-decode-field-body (field-body field-name + &optional mode max-column) (mime-decode-field-body field-body - (if (stringp field-name) - (intern (capitalize field-name)) - field-name) - mode max-column)) - -(defsubst make-full-mail-header - (&optional number subject from date id references chars lines xref extra) + (if (stringp field-name) + (intern (capitalize field-name)) + field-name) + mode max-column)) + +(defsubst make-full-mail-header (&optional number subject from date id + references chars lines xref + extra) "Create a new mail header structure initialized with the parameters given." - (make-mime-entity-internal - 'gnus number - nil - nil nil nil - (if subject - (nnheader-decode-subject subject) - ) - (if from - (nnheader-decode-from from) - ) - date id references - chars lines xref - (list (cons 'Subject subject) - (cons 'From from)) - nil nil nil nil nil nil -;; extra - )) + (luna-make-entity (mm-expand-class-name 'gnus) + :location number + :subject (if subject + (nnheader-decode-subject subject)) + :from (if from + (nnheader-decode-from from)) + :date date + :id id + :references references + :chars chars + :lines lines + :xref xref + :original-header (list (cons 'Subject subject) + (cons 'From from)) + :extra extra)) (defsubst make-full-mail-header-from-decoded-header (&optional number subject from date id references chars lines xref extra) "Create a new mail header structure initialized with the parameters given." - (make-mime-entity-internal - 'gnus number - nil - nil nil nil - subject - from - date id references - chars lines xref - nil - nil nil nil nil nil nil -;; extra - )) - -(defun make-mail-header (&optional init) + (luna-make-entity (mm-expand-class-name 'gnus) + :location number + :subject subject + :from from + :date date + :id id + :references references + :chars chars + :lines lines + :xref xref + :extra extra)) + +(defsubst make-mail-header (&optional init) "Create a new mail header structure initialized with INIT." (make-full-mail-header init init init init init init init init init init)) @@ -174,7 +189,10 @@ on your system, you could say something like: ;; Parsing headers and NOV lines. (defsubst nnheader-header-value () - (buffer-substring (match-end 0) (gnus-point-at-eol))) + (let ((pt (point))) + (prog1 + (buffer-substring (match-end 0) (std11-field-end)) + (goto-char pt)))) (defun nnheader-parse-head (&optional naked) (let ((case-fold-search t) @@ -216,7 +234,8 @@ on your system, you could say something like: ;; From. (progn (goto-char p) - (if (search-forward "\nfrom: " nil t) + (if (or (search-forward "\nfrom: " nil t) + (search-forward "\nfrom:" nil t)) (nnheader-header-value) "(nobody)")) ;; Date. (progn @@ -244,11 +263,12 @@ on your system, you could say something like: ;; promising. (if (and (search-forward "\nin-reply-to: " nil t) (setq in-reply-to (nnheader-header-value)) - (string-match "<[^>]+>" in-reply-to)) + (string-match "<[^\n>]+>" in-reply-to)) (let (ref2) (setq ref (substring in-reply-to (match-beginning 0) (match-end 0))) - (while (string-match "<[^>]+>" in-reply-to (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)) @@ -296,7 +316,9 @@ on your system, you could say something like: '(prog1 (if (eq (char-after) ?\t) 0 - (let ((num (ignore-errors (read (current-buffer))))) + (let ((num (condition-case nil + (read (current-buffer)) + (error nil)))) (if (numberp num) num 0))) (unless (eobp) (search-forward "\t" eol 'move)))) @@ -330,36 +352,54 @@ on your system, you could say something like: (nnheader-nov-read-integer) ; lines (if (eq (char-after) ?\n) nil - (nnheader-nov-field)) ; misc + (if (looking-at "Xref: ") + (goto-char (match-end 0))) + (nnheader-nov-field)) ; Xref (nnheader-nov-parse-extra)))) ; extra (defun nnheader-insert-nov (header) (princ (mail-header-number header) (current-buffer)) + (let ((p (point))) + (insert + "\t" + (or (mime-entity-fetch-field header 'Subject) "(none)") "\t" + (or (mime-entity-fetch-field header 'From) "(nobody)") "\t" + (or (mail-header-date header) "") "\t" + (or (mail-header-id header) + (nnmail-message-id)) + "\t" + (or (mail-header-references header) "") "\t") + (princ (or (mail-header-chars header) 0) (current-buffer)) + (insert "\t") + (princ (or (mail-header-lines header) 0) (current-buffer)) + (insert "\t") + (when (mail-header-xref header) + (insert "Xref: " (mail-header-xref header))) + (when (or (mail-header-xref header) + (mail-header-extra header)) + (insert "\t")) + (when (mail-header-extra header) + (let ((extra (mail-header-extra header))) + (while extra + (insert (symbol-name (caar extra)) + ": " (cdar extra) "\t") + (pop extra)))) + (insert "\n") + (backward-char 1) + (while (search-backward "\n" p t) + (delete-char 1)) + (forward-line 1))) + +(defun nnheader-insert-header (header) (insert - "\t" - (or (mime-fetch-field 'Subject header) "(none)") "\t" - (or (mime-fetch-field 'From header) "(nobody)") "\t" - (or (mail-header-date header) "") "\t" - (or (mail-header-id header) - (nnmail-message-id)) - "\t" - (or (mail-header-references header) "") "\t") - (princ (or (mail-header-chars header) 0) (current-buffer)) - (insert "\t") + "Subject: " (or (mail-header-subject header) "(none)") "\n" + "From: " (or (mail-header-from header) "(nobody)") "\n" + "Date: " (or (mail-header-date header) "") "\n" + "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n" + "References: " (or (mail-header-references header) "") "\n" + "Lines: ") (princ (or (mail-header-lines header) 0) (current-buffer)) - (insert "\t") - (when (mail-header-xref header) - (insert "Xref: " (mail-header-xref header))) - (when (or (mail-header-xref header) - (mail-header-extra header)) - (insert "\t")) - (when (mail-header-extra header) - (let ((extra (mail-header-extra header))) - (while extra - (insert (symbol-name (caar extra)) - ": " (cdar extra) "\t") - (pop extra)))) - (insert "\n")) + (insert "\n\n")) (defun nnheader-insert-article-line (article) (goto-char (point-min)) @@ -438,6 +478,7 @@ the line could be found." (let* ((file nil) (number (length articles)) (count 0) + (file-name-coding-system 'binary) (pathname-coding-system 'binary) (case-fold-search t) (cur (current-buffer)) @@ -733,7 +774,7 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')." (erase-buffer)) (current-buffer)) -(defvar jka-compr-compression-info-list) +(eval-when-compile (defvar jka-compr-compression-info-list)) (defvar nnheader-numerical-files (if (boundp 'jka-compr-compression-info-list) (concat "\\([0-9]+\\)\\(" @@ -750,17 +791,20 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')." "Regexp that matches numerical full file paths.") (defsubst nnheader-file-to-number (file) - "Take a file name and return the article number." + "Take a FILE name and return the article number." (if (string= nnheader-numerical-short-files "^[0-9]+$") (string-to-int file) (string-match nnheader-numerical-short-files file) (string-to-int (match-string 0 file)))) +(defvar nnheader-directory-files-is-safe nil + "If non-nil, Gnus believes `directory-files' is safe. +It has been reported numerous times that `directory-files' fails with +an alarming frequency on NFS mounted file systems. If it is nil, +`nnheader-directory-files-safe' is used.") + (defun nnheader-directory-files-safe (&rest args) - ;; It has been reported numerous times that `directory-files' - ;; fails with an alarming frequency on NFS mounted file systems. - ;; This function executes that function twice and returns - ;; the longest result. + "Execute `directory-files' twice and returns the longer result." (let ((first (apply 'directory-files args)) (second (apply 'directory-files args))) (if (> (length first) (length second)) @@ -768,16 +812,22 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')." second))) (defun nnheader-directory-articles (dir) - "Return a list of all article files in a directory." + "Return a list of all article files in directory DIR." (mapcar 'nnheader-file-to-number - (nnheader-directory-files-safe - dir nil nnheader-numerical-short-files t))) + (if nnheader-directory-files-is-safe + (directory-files + dir nil nnheader-numerical-short-files t) + (nnheader-directory-files-safe + dir nil nnheader-numerical-short-files t)))) (defun nnheader-article-to-file-alist (dir) "Return an alist of article/file pairs in DIR." (mapcar (lambda (file) (cons (nnheader-file-to-number file) file)) - (nnheader-directory-files-safe - dir nil nnheader-numerical-short-files t))) + (if nnheader-directory-files-is-safe + (directory-files + dir nil nnheader-numerical-short-files t) + (nnheader-directory-files-safe + dir nil nnheader-numerical-short-files t)))) (defun nnheader-fold-continuation-lines () "Fold continuation lines in the current buffer." @@ -794,14 +844,31 @@ If FULL, translate everything." (if full ;; Do complete translation. (setq leaf (copy-sequence file) - path "") + path "" + i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1))) + 2 0)) ;; We translate -- but only the file name. We leave the directory ;; alone. - (if (string-match "/[^/]+\\'" file) - ;; This is needed on NT's and stuff. - (setq leaf (substring file (1+ (match-beginning 0))) - path (substring file 0 (1+ (match-beginning 0)))) - ;; Fall back on this. + (if (and (featurep 'xemacs) + (memq system-type '(win32 w32 mswindows windows-nt))) + ;; This is needed on NT and stuff, because + ;; file-name-nondirectory is not enough to split + ;; file names, containing ':', e.g. + ;; "d:\\Work\\News\\nntp+news.fido7.ru:fido7.ru.gnu.SCORE" + ;; + ;; we are trying to correctly split such names: + ;; "d:file.name" -> "a:" "file.name" + ;; "aaa:bbb.ccc" -> "" "aaa:bbb.ccc" + ;; "d:aaa\\bbb:ccc" -> "d:aaa\\" "bbb:ccc" + ;; etc. + ;; to translate then only the file name part. + (progn + (setq leaf file + path "") + (if (string-match "\\(^\\w:\\|[/\\]\\)\\([^/\\]+\\)$" file) + (setq leaf (substring file (match-beginning 2)) + path (substring file 0 (match-beginning 2))))) + ;; Emacs DTRT, says andrewi. (setq leaf (file-name-nondirectory file) path (file-name-directory file)))) (setq len (length leaf)) @@ -825,7 +892,7 @@ The first string in ARGS can be a format string." "Get the most recent report from BACKEND." (condition-case () (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string" - backend)))) + backend)))) (error (nnheader-message 5 "")))) (defun nnheader-insert (format &rest args) @@ -840,15 +907,33 @@ without formatting." (apply 'insert format args)) t)) -(defun nnheader-replace-chars-in-string (string from to) +(static-if (fboundp 'subst-char-in-string) + (defsubst nnheader-replace-chars-in-string (string from to) + (subst-char-in-string from to string)) + (defun nnheader-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurrences of FROM with TO. + (while (< idx len) + (when (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string))) + +(defun nnheader-replace-duplicate-chars-in-string (string from to) "Replace characters in STRING from FROM to TO." (let ((string (substring string 0)) ;Copy string. (len (length string)) - (idx 0)) + (idx 0) prev i) ;; Replace all occurrences of FROM with TO. (while (< idx len) - (when (= (aref string idx) from) + (setq i (aref string idx)) + (when (and (eq prev from) (= i from)) + (aset string (1- idx) to) (aset string idx to)) + (setq prev i) (setq idx (1+ idx))) string)) @@ -885,14 +970,14 @@ without formatting." (concat (let ((dir (file-name-as-directory (expand-file-name dir)))) ;; If this directory exists, we use it directly. - (if (file-directory-p (concat dir group)) - (concat dir group "/") - ;; If not, we translate dots into slashes. - (concat dir - (encode-coding-string - (nnheader-replace-chars-in-string group ?. ?/) - nnheader-pathname-coding-system) - "/"))) + (file-name-as-directory + (if (file-directory-p (concat dir group)) + (expand-file-name group dir) + ;; If not, we translate dots into slashes. + (expand-file-name (encode-coding-string + (nnheader-replace-chars-in-string group ?. ?/) + nnheader-pathname-coding-system) + dir)))) (cond ((null file) "") ((numberp file) (int-to-string file)) (t file)))) @@ -903,7 +988,7 @@ without formatting." (and (listp form) (eq (car form) 'lambda)))) (defun nnheader-concat (dir &rest files) - "Concat DIR as directory to FILE." + "Concat DIR as directory to FILES." (apply 'concat (file-name-as-directory dir) files)) (defun nnheader-ms-strip-cr () @@ -963,6 +1048,7 @@ find-file-hooks, etc. (default-major-mode 'fundamental-mode) (enable-local-variables nil) (after-insert-file-functions nil) + (enable-local-eval nil) (find-file-hooks nil)) (insert-file-contents-as-coding-system nnheader-file-coding-system filename visit beg end replace))) @@ -973,6 +1059,7 @@ find-file-hooks, etc. (default-major-mode 'fundamental-mode) (enable-local-variables nil) (after-insert-file-functions nil) + (enable-local-eval nil) (find-file-hooks nil)) (apply 'find-file-noselect-as-coding-system nnheader-file-coding-system args))) @@ -1028,20 +1115,20 @@ find-file-hooks, etc. (set-buffer cur))) (defun nnheader-replace-string (from to) - "Do a fast replacement of FROM to TO from point to point-max." + "Do a fast replacement of FROM to TO from point to `point-max'." (nnheader-skeleton-replace from to)) (defun nnheader-replace-regexp (from to) - "Do a fast regexp replacement of FROM to TO from point to point-max." + "Do a fast regexp replacement of FROM to TO from point to `point-max'." (nnheader-skeleton-replace from to t)) (defun nnheader-strip-cr () "Strip all \r's from the current buffer." (nnheader-skeleton-replace "\r")) -(fset 'nnheader-run-at-time 'run-at-time) -(fset 'nnheader-cancel-timer 'cancel-timer) -(fset 'nnheader-cancel-function-timers 'cancel-function-timers) +(defalias 'nnheader-run-at-time 'run-at-time) +(defalias 'nnheader-cancel-timer 'cancel-timer) +(defalias 'nnheader-cancel-function-timers 'cancel-function-timers) (defun nnheader-Y-or-n-p (prompt) "Ask user a \"Y/n\" question. Return t if answer is neither \"n\", \"N\" nor \"C-g\"." @@ -1060,7 +1147,7 @@ find-file-hooks, etc. (message "%s(Y/n) Yes" prompt) t))) -(when (string-match "XEmacs\\|Lucid" emacs-version) +(when (featurep 'xemacs) (require 'nnheaderxm)) (run-hooks 'nnheader-load-hook)