60187ad5e83b4025147167a02e9fd71aebe15bce
[elisp/gnus.git-] / lisp / nnheader.el
1 ;;; nnheader.el --- header access macros for Semi-gnus and its backends
2 ;; Copyright (C) 1987,88,89,90,93,94,95,96,97,98 Free Software Foundation, Inc.
3
4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5 ;;         Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
7 ;; Keywords: mail, news, MIME
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Commentary:
27
28 ;; These macros may look very much like the ones in GNUS 4.1.  They
29 ;; are, in a way, but you should note that the indices they use have
30 ;; been changed from the internal GNUS format to the NOV format.  The
31 ;; makes it possible to read headers from XOVER much faster.
32 ;;
33 ;; The format of a header is now:
34 ;; [number subject from date id references chars lines xref]
35 ;;
36 ;; (That last entry is defined as "misc" in the NOV format, but Gnus
37 ;; uses it for xrefs.)
38
39 ;;; Code:
40
41 (eval-when-compile (require 'cl))
42
43 (require 'mail-utils)
44 (require 'mime)
45
46 (defvar nnheader-max-head-length 4096
47   "*Max length of the head of articles.")
48
49 (defvar nnheader-head-chop-length 2048
50   "*Length of each read operation when trying to fetch HEAD headers.")
51
52 (defvar nnheader-file-name-translation-alist nil
53   "*Alist that says how to translate characters in file names.
54 For instance, if \":\" is illegal as a file character in file names
55 on your system, you could say something like:
56
57 \(setq nnheader-file-name-translation-alist '((?: . ?_)))")
58
59 (eval-and-compile
60  (autoload 'nnmail-message-id "nnmail")
61  (autoload 'mail-position-on-field "sendmail")
62  (autoload 'message-remove-header "message")
63  (autoload 'cancel-function-timers "timers")
64  (autoload 'gnus-point-at-eol "gnus-util")
65  (autoload 'gnus-delete-line "gnus-util")
66  (autoload 'gnus-buffer-live-p "gnus-util")
67  (autoload 'gnus-encode-coding-string "gnus-ems"))
68
69 ;;; Header access macros.
70
71 (defmacro mail-header-number (header)
72   "Return article number in HEADER."
73   `(mime-entity-location-internal ,header))
74
75 (defmacro mail-header-set-number (header number)
76   "Set article number of HEADER to NUMBER."
77   `(mime-entity-set-location-internal ,header ,number))
78
79 (defalias 'mail-header-subject 'mime-entity-decoded-subject-internal)
80 (defalias 'mail-header-set-subject 'mime-entity-set-decoded-subject-internal)
81
82 (defalias 'mail-header-from 'mime-entity-decoded-from-internal)
83 (defalias 'mail-header-set-from 'mime-entity-set-decoded-from-internal)
84
85 (defalias 'mail-header-date 'mime-entity-date-internal)
86 (defalias 'mail-header-set-date 'mime-entity-set-date-internal)
87
88 (defalias 'mail-header-message-id 'mime-entity-message-id-internal)
89 (defalias 'mail-header-id 'mime-entity-message-id-internal)
90 (defalias 'mail-header-set-message-id 'mime-entity-set-message-id-internal)
91 (defalias 'mail-header-set-id 'mime-entity-set-message-id-internal)
92
93 (defalias 'mail-header-references 'mime-entity-references-internal)
94 (defalias 'mail-header-set-references 'mime-entity-set-references-internal)
95
96 (defalias 'mail-header-chars 'mime-entity-chars-internal)
97 (defalias 'mail-header-set-chars 'mime-entity-set-chars-internal)
98
99 (defalias 'mail-header-lines 'mime-entity-lines-internal)
100 (defalias 'mail-header-set-lines 'mime-entity-set-lines-internal)
101
102 (defalias 'mail-header-xref 'mime-entity-xref-internal)
103 (defalias 'mail-header-set-xref 'mime-entity-set-xref-internal)
104
105 (defsubst make-full-mail-header (&optional number subject from date id
106                                            references chars lines xref)
107   "Create a new mail header structure initialized with the parameters given."
108   (make-mime-entity-internal
109    'gnus number
110    nil
111    nil nil nil
112    (if subject
113        (eword-decode-and-unfold-unstructured-field subject)
114      )
115    (if from
116        (eword-decode-and-unfold-structured-field from)
117      )
118    date id references
119    chars lines xref
120    (list (cons 'Subject subject)
121          (cons 'From from))
122    ))
123
124 (defsubst make-full-mail-header-from-decoded-header
125   (&optional number subject from date id references chars lines xref)
126   "Create a new mail header structure initialized with the parameters given."
127   (make-mime-entity-internal
128    'gnus number
129    nil
130    nil nil nil
131    subject
132    from
133    date id references
134    chars lines xref))
135
136 (defun make-mail-header (&optional init)
137   "Create a new mail header structure initialized with INIT."
138   (make-full-mail-header init init init init init
139                          init init init init))
140
141 ;; fake message-ids: generation and detection
142
143 (defvar nnheader-fake-message-id 1)
144
145 (defsubst nnheader-generate-fake-message-id ()
146   (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id))))
147
148 (defsubst nnheader-fake-message-id-p (id)
149   (save-match-data                      ; regular message-id's are <.*>
150     (string-match "\\`fake\\+none\\+[0-9]+\\'" id)))
151
152 ;; Parsing headers and NOV lines.
153
154 (defsubst nnheader-header-value ()
155   (buffer-substring (match-end 0) (gnus-point-at-eol)))
156
157 (defun nnheader-parse-head (&optional naked)
158   (let ((case-fold-search t)
159         (cur (current-buffer))
160         (buffer-read-only nil)
161         in-reply-to lines p ref)
162     (goto-char (point-min))
163     (when naked
164       (insert "\n"))
165     ;; Search to the beginning of the next header.  Error messages
166     ;; do not begin with 2 or 3.
167     (prog1
168         (when (or naked (re-search-forward "^[23][0-9]+ " nil t))
169           ;; This implementation of this function, with nine
170           ;; search-forwards instead of the one re-search-forward and
171           ;; a case (which basically was the old function) is actually
172           ;; about twice as fast, even though it looks messier.  You
173           ;; can't have everything, I guess.  Speed and elegance
174           ;; don't always go hand in hand.
175           (make-full-mail-header-from-decoded-header
176            ;; Number.
177            (if naked
178                (progn
179                  (setq p (point-min))
180                  0)
181              (prog1
182                  (read cur)
183                (end-of-line)
184                (setq p (point))
185                (narrow-to-region (point)
186                                  (or (and (search-forward "\n.\n" nil t)
187                                           (- (point) 2))
188                                      (point)))))
189            ;; Subject.
190            (progn
191              (goto-char p)
192              (if (search-forward "\nsubject: " nil t)
193                  (nnheader-header-value) "(none)"))
194            ;; From.
195            (progn
196              (goto-char p)
197              (if (search-forward "\nfrom: " nil t)
198                  (nnheader-header-value) "(nobody)"))
199            ;; Date.
200            (progn
201              (goto-char p)
202              (if (search-forward "\ndate: " nil t)
203                  (nnheader-header-value) ""))
204            ;; Message-ID.
205            (progn
206              (goto-char p)
207              (if (search-forward "\nmessage-id:" nil t)
208                  (buffer-substring
209                   (1- (or (search-forward "<" (gnus-point-at-eol) t)
210                           (point)))
211                   (or (search-forward ">" (gnus-point-at-eol) t) (point)))
212                ;; If there was no message-id, we just fake one to make
213                ;; subsequent routines simpler.
214                (nnheader-generate-fake-message-id)))
215            ;; References.
216            (progn
217              (goto-char p)
218              (if (search-forward "\nreferences: " nil t)
219                  (nnheader-header-value)
220                ;; Get the references from the in-reply-to header if there
221                ;; were no references and the in-reply-to header looks
222                ;; promising.
223                (if (and (search-forward "\nin-reply-to: " nil t)
224                         (setq in-reply-to (nnheader-header-value))
225                         (string-match "<[^>]+>" in-reply-to))
226                    (let (ref2)
227                      (setq ref (substring in-reply-to (match-beginning 0)
228                                           (match-end 0)))
229                      (while (string-match "<[^>]+>" in-reply-to (match-end 0))
230                        (setq ref2 (substring in-reply-to (match-beginning 0)
231                                              (match-end 0)))
232                        (when (> (length ref2) (length ref))
233                          (setq ref ref2)))
234                      ref)
235                  nil)))
236            ;; Chars.
237            0
238            ;; Lines.
239            (progn
240              (goto-char p)
241              (if (search-forward "\nlines: " nil t)
242                  (if (numberp (setq lines (read cur)))
243                      lines 0)
244                0))
245            ;; Xref.
246            (progn
247              (goto-char p)
248              (and (search-forward "\nxref: " nil t)
249                   (nnheader-header-value)))))
250       (when naked
251         (goto-char (point-min))
252         (delete-char 1)))))
253
254 (defmacro nnheader-nov-skip-field ()
255   '(search-forward "\t" eol 'move))
256
257 (defmacro nnheader-nov-field ()
258   '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol)))
259
260 (defmacro nnheader-nov-read-integer ()
261   '(prog1
262        (if (= (following-char) ?\t)
263            0
264          (let ((num (ignore-errors (read (current-buffer)))))
265            (if (numberp num) num 0)))
266      (or (eobp) (forward-char 1))))
267
268 ;; (defvar nnheader-none-counter 0)
269
270 (defun nnheader-parse-nov ()
271   (let ((eol (gnus-point-at-eol)))
272     (make-full-mail-header
273      (nnheader-nov-read-integer)        ; number
274      (nnheader-nov-field)               ; subject
275      (nnheader-nov-field)               ; from
276      (nnheader-nov-field)               ; date
277      (or (nnheader-nov-field)
278          (nnheader-generate-fake-message-id)) ; id
279      (nnheader-nov-field)               ; refs
280      (nnheader-nov-read-integer)        ; chars
281      (nnheader-nov-read-integer)        ; lines
282      (if (= (following-char) ?\n)
283          nil
284        (nnheader-nov-field))            ; misc
285      )))
286
287 (defun nnheader-insert-nov (header)
288   (princ (mail-header-number header) (current-buffer))
289   (insert
290    "\t"
291    (or (mime-fetch-field 'Subject header) "(none)") "\t"
292    (or (mime-fetch-field 'From header) "(nobody)") "\t"
293    (or (mail-header-date header) "") "\t"
294    (or (mail-header-id header)
295        (nnmail-message-id))
296    "\t"
297    (or (mail-header-references header) "") "\t")
298   (princ (or (mail-header-chars header) 0) (current-buffer))
299   (insert "\t")
300   (princ (or (mail-header-lines header) 0) (current-buffer))
301   (insert "\t")
302   (when (mail-header-xref header)
303     (insert "Xref: " (mail-header-xref header) "\t"))
304   (insert "\n"))
305
306 (defun nnheader-insert-article-line (article)
307   (goto-char (point-min))
308   (insert "220 ")
309   (princ article (current-buffer))
310   (insert " Article retrieved.\n")
311   (search-forward "\n\n" nil 'move)
312   (delete-region (point) (point-max))
313   (forward-char -1)
314   (insert "."))
315
316 (defun nnheader-nov-delete-outside-range (beg end)
317   "Delete all NOV lines that lie outside the BEG to END range."
318   ;; First we find the first wanted line.
319   (nnheader-find-nov-line beg)
320   (delete-region (point-min) (point))
321   ;; Then we find the last wanted line.
322   (when (nnheader-find-nov-line end)
323     (forward-line 1))
324   (delete-region (point) (point-max)))
325
326 (defun nnheader-find-nov-line (article)
327   "Put point at the NOV line that start with ARTICLE.
328 If ARTICLE doesn't exist, put point where that line
329 would have been.  The function will return non-nil if
330 the line could be found."
331   ;; This function basically does a binary search.
332   (let ((max (point-max))
333         (min (goto-char (point-min)))
334         (cur (current-buffer))
335         (prev (point-min))
336         num found)
337     (while (not found)
338       (goto-char (/ (+ max min) 2))
339       (beginning-of-line)
340       (if (or (= (point) prev)
341               (eobp))
342           (setq found t)
343         (setq prev (point))
344         (while (and (not (numberp (setq num (read cur))))
345                     (not (eobp)))
346           (gnus-delete-line))
347         (cond ((> num article)
348                (setq max (point)))
349               ((< num article)
350                (setq min (point)))
351               (t
352                (setq found 'yes)))))
353     ;; We may be at the first line.
354     (when (and (not num)
355                (not (eobp)))
356       (setq num (read cur)))
357     ;; Now we may have found the article we're looking for, or we
358     ;; may be somewhere near it.
359     (when (and (not (eq found 'yes))
360                (not (eq num article)))
361       (setq found (point))
362       (while (and (< (point) max)
363                   (or (not (numberp num))
364                       (< num article)))
365         (forward-line 1)
366         (setq found (point))
367         (or (eobp)
368             (= (setq num (read cur)) article)))
369       (unless (eq num article)
370         (goto-char found)))
371     (beginning-of-line)
372     (eq num article)))
373
374 ;; Various cruft the backends and Gnus need to communicate.
375
376 (defvar nntp-server-buffer nil)
377 (defvar gnus-verbose-backends 7
378   "*A number that says how talkative the Gnus backends should be.")
379 (defvar gnus-nov-is-evil nil
380   "If non-nil, Gnus backends will never output headers in the NOV format.")
381 (defvar news-reply-yank-from nil)
382 (defvar news-reply-yank-message-id nil)
383
384 (defvar nnheader-callback-function nil)
385
386 (defun nnheader-init-server-buffer ()
387   "Initialize the Gnus-backend communication buffer."
388   (save-excursion
389     (unless (gnus-buffer-live-p nntp-server-buffer)
390       (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
391     (set-buffer nntp-server-buffer)
392     (erase-buffer)
393     (kill-all-local-variables)
394     (setq case-fold-search t)           ;Should ignore case.
395     t))
396
397 ;;; Various functions the backends use.
398
399 (defun nnheader-file-error (file)
400   "Return a string that says what is wrong with FILE."
401   (format
402    (cond
403     ((not (file-exists-p file))
404      "%s does not exist")
405     ((file-directory-p file)
406      "%s is a directory")
407     ((not (file-readable-p file))
408      "%s is not readable"))
409    file))
410
411 (defun nnheader-insert-head (file)
412   "Insert the head of the article."
413   (when (file-exists-p file)
414     (if (eq nnheader-max-head-length t)
415         ;; Just read the entire file.
416         (nnheader-insert-file-contents file)
417       ;; Read 1K blocks until we find a separator.
418       (let ((beg 0)
419             format-alist)
420         (while (and (eq nnheader-head-chop-length
421                         (nth 1 (nnheader-insert-file-contents
422                                 file nil beg
423                                 (incf beg nnheader-head-chop-length))))
424                     (prog1 (not (search-forward "\n\n" nil t))
425                       (goto-char (point-max)))
426                     (or (null nnheader-max-head-length)
427                         (< beg nnheader-max-head-length))))))
428     t))
429
430 (defun nnheader-article-p ()
431   "Say whether the current buffer looks like an article."
432   (goto-char (point-min))
433   (if (not (search-forward "\n\n" nil t))
434       nil
435     (narrow-to-region (point-min) (1- (point)))
436     (goto-char (point-min))
437     (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
438       (goto-char (match-end 0)))
439     (prog1
440         (eobp)
441       (widen))))
442
443 (defun nnheader-insert-references (references message-id)
444   "Insert a References header based on REFERENCES and MESSAGE-ID."
445   (if (and (not references) (not message-id))
446       ()                                ; This is illegal, but not all articles have Message-IDs.
447     (mail-position-on-field "References")
448     (let ((begin (save-excursion (beginning-of-line) (point)))
449           (fill-column 78)
450           (fill-prefix "\t"))
451       (when references
452         (insert references))
453       (when (and references message-id)
454         (insert " "))
455       (when message-id
456         (insert message-id))
457       ;; Fold long References lines to conform to RFC1036 (sort of).
458       ;; The region must end with a newline to fill the region
459       ;; without inserting extra newline.
460       (fill-region-as-paragraph begin (1+ (point))))))
461
462 (defun nnheader-replace-header (header new-value)
463   "Remove HEADER and insert the NEW-VALUE."
464   (save-excursion
465     (save-restriction
466       (nnheader-narrow-to-headers)
467       (prog1
468           (message-remove-header header)
469         (goto-char (point-max))
470         (insert header ": " new-value "\n")))))
471
472 (defun nnheader-narrow-to-headers ()
473   "Narrow to the head of an article."
474   (widen)
475   (narrow-to-region
476    (goto-char (point-min))
477    (if (search-forward "\n\n" nil t)
478        (1- (point))
479      (point-max)))
480   (goto-char (point-min)))
481
482 (defun nnheader-set-temp-buffer (name &optional noerase)
483   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
484   (set-buffer (get-buffer-create name))
485   (buffer-disable-undo (current-buffer))
486   (unless noerase
487     (erase-buffer))
488   (current-buffer))
489
490 (defmacro nnheader-temp-write (file &rest forms)
491   "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
492 Return the value of FORMS.
493 If FILE is nil, just evaluate FORMS and don't save anything.
494 If FILE is t, return the buffer contents as a string."
495   (let ((temp-file (make-symbol "temp-file"))
496         (temp-buffer (make-symbol "temp-buffer"))
497         (temp-results (make-symbol "temp-results")))
498     `(save-excursion
499        (let* ((,temp-file ,file)
500               (default-major-mode 'fundamental-mode)
501               (,temp-buffer
502                (set-buffer
503                 (get-buffer-create
504                  (generate-new-buffer-name " *nnheader temp*"))))
505               ,temp-results)
506          (unwind-protect
507              (progn
508                (setq ,temp-results (progn ,@forms))
509                (cond
510                 ;; Don't save anything.
511                 ((null ,temp-file)
512                  ,temp-results)
513                 ;; Return the buffer contents.
514                 ((eq ,temp-file t)
515                  (set-buffer ,temp-buffer)
516                  (buffer-string))
517                 ;; Save a file.
518                 (t
519                  (set-buffer ,temp-buffer)
520                  ;; Make sure the directory where this file is
521                  ;; to be saved exists.
522                  (when (not (file-directory-p
523                              (file-name-directory ,temp-file)))
524                    (make-directory (file-name-directory ,temp-file) t))
525                  ;; Save the file.
526                  (write-region (point-min) (point-max)
527                                ,temp-file nil 'nomesg)
528                  ,temp-results)))
529            ;; Kill the buffer.
530            (when (buffer-name ,temp-buffer)
531              (kill-buffer ,temp-buffer)))))))
532
533 (put 'nnheader-temp-write 'lisp-indent-function 1)
534 (put 'nnheader-temp-write 'edebug-form-spec '(form body))
535
536 (defvar jka-compr-compression-info-list)
537 (defvar nnheader-numerical-files
538   (if (boundp 'jka-compr-compression-info-list)
539       (concat "\\([0-9]+\\)\\("
540               (mapconcat (lambda (i) (aref i 0))
541                          jka-compr-compression-info-list "\\|")
542               "\\)?")
543     "[0-9]+$")
544   "Regexp that match numerical files.")
545
546 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
547   "Regexp that matches numerical file names.")
548
549 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
550   "Regexp that matches numerical full file paths.")
551
552 (defsubst nnheader-file-to-number (file)
553   "Take a file name and return the article number."
554   (if (string= nnheader-numerical-short-files "^[0-9]+$")
555       (string-to-int file)
556     (string-match nnheader-numerical-short-files file)
557     (string-to-int (match-string 0 file))))
558
559 (defun nnheader-directory-files-safe (&rest args)
560   ;; It has been reported numerous times that `directory-files'
561   ;; fails with an alarming frequency on NFS mounted file systems.
562   ;; This function executes that function twice and returns
563   ;; the longest result.
564   (let ((first (apply 'directory-files args))
565         (second (apply 'directory-files args)))
566     (if (> (length first) (length second))
567         first
568       second)))
569
570 (defun nnheader-directory-articles (dir)
571   "Return a list of all article files in a directory."
572   (mapcar 'nnheader-file-to-number
573           (nnheader-directory-files-safe
574            dir nil nnheader-numerical-short-files t)))
575
576 (defun nnheader-article-to-file-alist (dir)
577   "Return an alist of article/file pairs in DIR."
578   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
579           (nnheader-directory-files-safe
580            dir nil nnheader-numerical-short-files t)))
581
582 (defun nnheader-fold-continuation-lines ()
583   "Fold continuation lines in the current buffer."
584   (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
585
586 (defun nnheader-translate-file-chars (file &optional full)
587   "Translate FILE into something that can be a file name.
588 If FULL, translate everything."
589   (if (null nnheader-file-name-translation-alist)
590       ;; No translation is necessary.
591       file
592     (let* ((i 0)
593            trans leaf path len)
594       (if full
595           ;; Do complete translation.
596           (setq leaf (copy-sequence file)
597                 path "")
598         ;; We translate -- but only the file name.  We leave the directory
599         ;; alone.
600         (if (string-match "/[^/]+\\'" file)
601             ;; This is needed on NT's and stuff.
602             (setq leaf (substring file (1+ (match-beginning 0)))
603                   path (substring file 0 (1+ (match-beginning 0))))
604           ;; Fall back on this.
605           (setq leaf (file-name-nondirectory file)
606                 path (file-name-directory file))))
607       (setq len (length leaf))
608       (while (< i len)
609         (when (setq trans (cdr (assq (aref leaf i)
610                                      nnheader-file-name-translation-alist)))
611           (aset leaf i trans))
612         (incf i))
613       (concat path leaf))))
614
615 (defun nnheader-report (backend &rest args)
616   "Report an error from the BACKEND.
617 The first string in ARGS can be a format string."
618   (set (intern (format "%s-status-string" backend))
619        (if (< (length args) 2)
620            (car args)
621          (apply 'format args)))
622   nil)
623
624 (defun nnheader-get-report (backend)
625   "Get the most recent report from BACKEND."
626   (condition-case ()
627       (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
628                                                   backend))))
629     (error (nnheader-message 5 ""))))
630
631 (defun nnheader-insert (format &rest args)
632   "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
633 If FORMAT isn't a format string, it and all ARGS will be inserted
634 without formatting."
635   (save-excursion
636     (set-buffer nntp-server-buffer)
637     (erase-buffer)
638     (if (string-match "%" format)
639         (insert (apply 'format format args))
640       (apply 'insert format args))
641     t))
642
643 (defun nnheader-replace-chars-in-string (string from to)
644   "Replace characters in STRING from FROM to TO."
645   (let ((string (substring string 0))   ;Copy string.
646         (len (length string))
647         (idx 0))
648     ;; Replace all occurrences of FROM with TO.
649     (while (< idx len)
650       (when (= (aref string idx) from)
651         (aset string idx to))
652       (setq idx (1+ idx)))
653     string))
654
655 (defun nnheader-file-to-group (file &optional top)
656   "Return a group name based on FILE and TOP."
657   (nnheader-replace-chars-in-string
658    (if (not top)
659        file
660      (condition-case ()
661          (substring (expand-file-name file)
662                     (length
663                      (expand-file-name
664                       (file-name-as-directory top))))
665        (error "")))
666    ?/ ?.))
667
668 (defun nnheader-message (level &rest args)
669   "Message if the Gnus backends are talkative."
670   (if (or (not (numberp gnus-verbose-backends))
671           (<= level gnus-verbose-backends))
672       (apply 'message args)
673     (apply 'format args)))
674
675 (defun nnheader-be-verbose (level)
676   "Return whether the backends should be verbose on LEVEL."
677   (or (not (numberp gnus-verbose-backends))
678       (<= level gnus-verbose-backends)))
679
680 (defvar nnheader-pathname-coding-system 'iso-8859-1
681   "*Coding system for pathname.")
682
683 (defun nnheader-group-pathname (group dir &optional file)
684   "Make pathname for GROUP."
685   (concat
686    (let ((dir (file-name-as-directory (expand-file-name dir))))
687      ;; If this directory exists, we use it directly.
688      (if (file-directory-p (concat dir group))
689          (concat dir group "/")
690        ;; If not, we translate dots into slashes.
691        (concat dir
692                (gnus-encode-coding-string
693                 (nnheader-replace-chars-in-string group ?. ?/)
694                 nnheader-pathname-coding-system)
695                "/")))
696    (cond ((null file) "")
697          ((numberp file) (int-to-string file))
698          (t file))))
699
700 (defun nnheader-functionp (form)
701   "Return non-nil if FORM is funcallable."
702   (or (and (symbolp form) (fboundp form))
703       (and (listp form) (eq (car form) 'lambda))))
704
705 (defun nnheader-concat (dir &rest files)
706   "Concat DIR as directory to FILE."
707   (apply 'concat (file-name-as-directory dir) files))
708
709 (defun nnheader-ms-strip-cr ()
710   "Strip ^M from the end of all lines."
711   (save-excursion
712     (goto-char (point-min))
713     (while (re-search-forward "\r$" nil t)
714       (delete-backward-char 1))))
715
716 (defun nnheader-file-size (file)
717   "Return the file size of FILE or 0."
718   (or (nth 7 (file-attributes file)) 0))
719
720 (defun nnheader-find-etc-directory (package &optional file)
721   "Go through the path and find the \".../etc/PACKAGE\" directory.
722 If FILE, find the \".../etc/PACKAGE\" file instead."
723   (let ((path load-path)
724         dir result)
725     ;; We try to find the dir by looking at the load path,
726     ;; stripping away the last component and adding "etc/".
727     (while path
728       (if (and (car path)
729                (file-exists-p
730                 (setq dir (concat
731                            (file-name-directory
732                             (directory-file-name (car path)))
733                            "etc/" package
734                            (if file "" "/"))))
735                (or file (file-directory-p dir)))
736           (setq result dir
737                 path nil)
738         (setq path (cdr path))))
739     result))
740
741 (defvar ange-ftp-path-format)
742 (defvar efs-path-regexp)
743 (defun nnheader-re-read-dir (path)
744   "Re-read directory PATH if PATH is on a remote system."
745   (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp))
746       (when (string-match efs-path-regexp path)
747         (efs-re-read-dir path))
748     (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
749       (when (string-match (car ange-ftp-path-format) path)
750         (ange-ftp-re-read-dir path)))))
751
752 (defvar nnheader-file-coding-system 'raw-text
753   "Coding system used in file backends of Gnus.")
754
755 (defun nnheader-insert-file-contents (filename &optional visit beg end replace)
756   "Like `insert-file-contents', q.v., but only reads in the file.
757 A buffer may be modified in several ways after reading into the buffer due
758 to advanced Emacs features, such as file-name-handlers, format decoding,
759 find-file-hooks, etc.
760   This function ensures that none of these modifications will take place."
761   (let ((format-alist nil)
762         (auto-mode-alist (nnheader-auto-mode-alist))
763         (default-major-mode 'fundamental-mode)
764         (enable-local-variables nil)
765         (after-insert-file-functions nil)
766         (find-file-hooks nil)
767         (coding-system-for-read nnheader-file-coding-system))
768     (insert-file-contents filename visit beg end replace)))
769
770 (defun nnheader-find-file-noselect (&rest args)
771   (let ((format-alist nil)
772         (auto-mode-alist (nnheader-auto-mode-alist))
773         (default-major-mode 'fundamental-mode)
774         (enable-local-variables nil)
775         (after-insert-file-functions nil)
776         (find-file-hooks nil)
777         (coding-system-for-read nnheader-file-coding-system))
778     (apply 'find-file-noselect args)))
779
780 (defun nnheader-auto-mode-alist ()
781   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
782   (let ((alist auto-mode-alist)
783         out)
784     (while alist
785       (when (listp (cdar alist))
786         (push (car alist) out))
787       (pop alist))
788     (nreverse out)))
789
790 (defun nnheader-directory-regular-files (dir)
791   "Return a list of all regular files in DIR."
792   (let ((files (directory-files dir t))
793         out)
794     (while files
795       (when (file-regular-p (car files))
796         (push (car files) out))
797       (pop files))
798     (nreverse out)))
799
800 (defun nnheader-directory-files (&rest args)
801   "Same as `directory-files', but prune \".\" and \"..\"."
802   (let ((files (apply 'directory-files args))
803         out)
804     (while files
805       (unless (member (file-name-nondirectory (car files)) '("." ".."))
806         (push (car files) out))
807       (pop files))
808     (nreverse out)))
809
810 (defmacro nnheader-skeleton-replace (from &optional to regexp)
811   `(let ((new (generate-new-buffer " *nnheader replace*"))
812          (cur (current-buffer))
813          (start (point-min)))
814      (set-buffer new)
815      (buffer-disable-undo (current-buffer))
816      (set-buffer cur)
817      (goto-char (point-min))
818      (while (,(if regexp 're-search-forward 'search-forward)
819              ,from nil t)
820        (insert-buffer-substring
821         cur start (prog1 (match-beginning 0) (set-buffer new)))
822        (goto-char (point-max))
823        ,(when to `(insert ,to))
824        (set-buffer cur)
825        (setq start (point)))
826      (insert-buffer-substring
827       cur start (prog1 (point-max) (set-buffer new)))
828      (copy-to-buffer cur (point-min) (point-max))
829      (kill-buffer (current-buffer))
830      (set-buffer cur)))
831
832 (defun nnheader-replace-string (from to)
833   "Do a fast replacement of FROM to TO from point to point-max."
834   (nnheader-skeleton-replace from to))
835
836 (defun nnheader-replace-regexp (from to)
837   "Do a fast regexp replacement of FROM to TO from point to point-max."
838   (nnheader-skeleton-replace from to t))
839
840 (defun nnheader-strip-cr ()
841   "Strip all \r's from the current buffer."
842   (nnheader-skeleton-replace "\r"))
843
844 (fset 'nnheader-run-at-time 'run-at-time)
845 (fset 'nnheader-cancel-timer 'cancel-timer)
846 (fset 'nnheader-cancel-function-timers 'cancel-function-timers)
847
848 (when (string-match "XEmacs\\|Lucid" emacs-version)
849   (require 'nnheaderxm))
850
851 (run-hooks 'nnheader-load-hook)
852
853 (provide 'nnheader)
854
855 ;;; nnheader.el ends here