Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-16 17:24:23 +00:00
Code Issues Projects Releases Packages Wiki Activity

#

Browse source
This commit is contained in:
Dave Love 1999-10-04 17:15:48 +00:00
parent d56a50549d
commit 6edcb099fc
50 changed files with 23251 additions and 46842 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
lisp/ChangeLog
View file

@ -1,3 +1,29 @@
1999-10-04 Dave Love <fx@gnu.org>
* cus-start.el: Add x-stretch-cursor, indicate-empty-lines,
scroll-up-aggressively, scroll-down-aggressively.
* widget.el (define-widget-keywords): Make dummy definition and
comment-out its use.
* time.el (display-time-mode): Add autoload cookie.
* term.el: Avoid ange-ftp related compilation warnings.
* sun-curs.el: Require sun-fns.
* msb.el: (msb--choose-file-menu): Use `completion-ignore-case' in
name comparisons.
* rect.el: Add/fix various doc strings. Add `*' to all the
interactive specs.
(delete-extract-rectangle): Doc fix from verna.
* tooltip.el (tooltip-mode): Customize this, per convention.
(tooltip-active): Option deleted.
* help-macro.el (three-step-help): Customize.
1999-10-03 Dave Love <fx@gnu.org>
* image.el (defimage): Remove redundant code. Substitute file in

23143
lisp/ChangeLog.7 Normal file
View file

File diff suppressed because it is too large Load diff

403
lisp/bdf.el
View file

@ -1,403 +0,0 @@
;;; bdf.el --- BDF font file handler for ps-print.
;; Copyright (C) 1998 Electrotechnical Laboratory, JAPAN.
;; Licensed to the Free Software Foundation.
;; Keywords: BDF, font, PostScript
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Functions for getting bitmap information from X's BDF font file are
;; provided.
;;; Code:
(eval-when-compile (require 'ps-print))
(defvar bdf-directory-list
nil
"*List of directories to search for `BDF' font files.")
(defun bdf-expand-file-name (bdfname)
"Return an abosolute path name of a `BDF' font file BDFNAME.
It searches directories listed in the variable `bdf-directory-list'
for BDFNAME."
(if (file-name-absolute-p bdfname)
(if (file-readable-p bdfname)
bdfname)
(let ((l bdf-directory-list))
(catch 'tag
(while l
(if (file-readable-p (expand-file-name bdfname (car l)))
(throw 'tag (expand-file-name bdfname (car l))))
(setq l (cdr l)))))))
(defsubst bdf-file-mod-time (filename)
"Return modification time of FILENAME.
The value is a list of two integers, the first integer has high-order
16 bits, the second has low 16 bits."
(nth 5 (file-attributes filename)))
(defun bdf-file-newer-than-time (filename mod-time)
"Return non-nil if and only if FILENAME is newer than MOD-TIME.
MOD-TIME is a modification time as a list of two integers, the first
integer has high-order 16 bits, the second has low 16 bits."
(let ((new-mod-time (bdf-file-mod-time (bdf-expand-file-name filename))))
(or (> (car new-mod-time) (car mod-time))
(and (= (car new-mod-time) (car mod-time))
(> (nth 1 new-mod-time) (nth 1 mod-time))))))
(defun bdf-find-file (bdfname)
"Return a buffer visiting a bdf file BDFNAME.
If BDFNAME is not an absolute path, directories listed in
`bdf-directory-list' is searched.
If BDFNAME doesn't exist, return nil."
(let ((buf (generate-new-buffer " *bdf-work*"))
(coding-system-for-read 'no-conversion))
(save-excursion
(set-buffer buf)
(insert-file-contents (bdf-expand-file-name bdfname))
buf)))
(defvar bdf-cache-file "~/.bdfcache.el"
"Name of cache file which contains information of `BDF' font files.")
(defvar bdf-cache nil
"Cached information of `BDF' font files. It is a list of FONT-INFO.
FONT-INFO is a list of the following format:
(BDFFILE ABSOLUTE-PATH MOD-TIME SIZE FONT-BOUNDING-BOX
RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
See the documentation of the function `bdf-read-font-info' for more detail.")
(defun bdf-read-cache ()
"Return a cached information about `BDF' font files from a cache file.
The variable `bdf-cache-file' holds the cache file name.
If the cache file is not readable, this return nil."
(setq bdf-cache nil)
(condition-case nil
(if (file-readable-p bdf-cache-file)
(load-file bdf-cache-file))
(error nil))
(if (not (listp bdf-cache))
(setq bdf-cache nil)))
(defun bdf-write-cache ()
"Write out cached information of `BDF' font file to a file.
The variable `bdf-cache-file' holds the cache file name.
The file is written if and only if the file alreay exists and writable."
(if (and bdf-cache
(file-exists-p bdf-cache-file)
(file-writable-p bdf-cache-file))
(write-region (format "(setq bdf-cache '%S)\n" bdf-cache)
nil bdf-cache-file)))
(defun bdf-set-cache (font-info)
"Cache FONT-INFO as information about one `BDF' font file.
FONT-INFO is a list of the following format:
(BDFFILE ABSOLUTE-PATH MOD-TIME SIZE FONT-BOUNDING-BOX
RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
See the documentation of the function `bdf-read-font-info' for more detail."
(let ((slot (assoc (car font-info) bdf-cache)))
(if slot
(setcdr slot (cdr font-info))
(setq bdf-cache (cons font-info bdf-cache)))))
(defun bdf-initialize ()
"Initialize `bdf' library."
(if (bdf-read-cache)
(add-hook 'kill-emacs-hook 'bdf-write-cache)))
(defun bdf-compact-code (code code-range)
(if (or (< code (aref code-range 4))
(> code (aref code-range 5)))
(setq code (aref code-range 6)))
(+ (* (- (lsh code -8) (aref code-range 0))
(1+ (- (aref code-range 3) (aref code-range 2))))
(- (logand code 255) (aref code-range 2))))
(defun bdf-expand-code (code code-range)
(let ((code0-range (1+ (- (aref code-range 3) (aref code-range 2)))))
(+ (* (+ (/ code code0-range) (aref code-range 0)) 256)
(+ (% code code0-range) (aref code-range 2)))))
(defun bdf-read-font-info (bdfname)
"Read `BDF' font file BDFNAME and return information (FONT-INFO) of the file.
FONT-INFO is a list of the following format:
(BDFFILE ABSOLUTE-PATH MOD-TIME FONT-BOUNDING-BOX
RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
BDFFILE is a name of a font file (excluding directory part).
ABSOLUTE-PATH is an absolute path of the font file.
MOD-TIME is last modification time as a list of two integers, the
first integer has high-order 16 bits, the second has low 16 bits.
SIZE is a size of the font. This value is got from SIZE record of the
font.
FONT-BOUNDING-BOX is the font bounding box as a list of four integers,
BBX-WIDTH, BBX-HEIGHT, BBX-XOFF, and BBX-YOFF.
RELATIVE-COMPOSE is an integer value of the font's property
`_MULE_RELATIVE_COMPOSE'. If the font doesn't have this property, the
value is 0.
BASELINE-OFFSET is an integer value of the font's property
`_MULE_BASELINE_OFFSET'. If the font doesn't have this property, the
value is 0.
CODE-RANGE is a vector of minimum 1st byte, maximum 1st byte, minimum
2nd byte, maximum 2nd byte, minimum code, maximum code, and default
code. For 1-byte fonts, the first two elements are 0.
MAXLEN is a maximum bytes of one glyph informaion in the font file.
OFFSET-VECTOR is a vector of a file position which starts bitmap data
of the glyph in the font file.
Nth element of OFFSET-VECTOR is a file position for the glyph of code
CODE, where N and CODE are in the following relation:
(bdf-compact-code CODE) => N, (bdf-expand-code N) => CODE"
(let ((absolute-path (bdf-expand-file-name bdfname))
(maxlen 0)
size
font-bounding-box
(relative-compose 'false)
(baseline-offset 0)
default-char
code-range
offset-vector
buf)
(if absolute-path
(message "Reading %s..." bdfname)
(error "BDF file %s doesn't exist" bdfname))
(setq buf (bdf-find-file absolute-path))
(unwind-protect
(save-excursion
(set-buffer buf)
(goto-char (point-min))
(search-forward "\nFONTBOUNDINGBOX")
(setq font-bounding-box (vector (read (current-buffer))
(read (current-buffer))
(read (current-buffer))
(read (current-buffer))))
;; The following kludgy code is to avoid bugs of fonts
;; jiskan16.bdf and jiskan24.bdf distributed with X.
;; They contain wrong FONTBOUNDINGBOX.
(if (and (> (aref font-bounding-box 3) 0)
(string-match "jiskan\\(16\\|24\\)" bdfname))
(aset font-bounding-box 3
(- (aref font-bounding-box 3))))
(goto-char (point-min))
(search-forward "\nSIZE ")
(setq size (read (current-buffer)))
;; The following kludgy code is t avoid bugs of several
;; fonts which have wrong SIZE record.
(if (<= size (/ (aref font-bounding-box 1) 2))
(setq size (aref font-bounding-box 1)))
(goto-char (point-min))
(if (search-forward "\nDEFAULT_CHAR" nil t)
(setq default-char (read (current-buffer))))
(search-forward "\nSTARTCHAR")
(forward-line -1)
(let ((limit (point)))
(goto-char (point-min))
(if (search-forward "\n_MULE_RELATIVE_COMPOSE" limit t)
(progn
(goto-char (match-end 0))
(setq relative-compose (read (current-buffer)))))
(goto-char (point-min))
(if (search-forward "\n_MULE_BASELINE_OFFSET" limit t)
(progn
(goto-char (match-end 0))
(setq baseline-offset (read (current-buffer))))))
(let ((min-code0 256) (min-code1 256) (max-code0 0) (max-code1 0)
(min-code 65536)
(max-code 0)
(glyph-list nil)
code bbx offset)
(while (search-forward "\nSTARTCHAR" nil t)
(setq offset (line-beginning-position))
(search-forward "\nENCODING")
(setq code (read (current-buffer)))
(let ((code0 (lsh code -8))
(code1 (logand code 255)))
(if (< code0 min-code0) (setq min-code0 code0)
(if (> code0 max-code0) (setq max-code0 code0)))
(if (< code1 min-code1) (setq min-code1 code1)
(if (> code1 max-code1) (setq max-code1 code1))))
(if (< code min-code)
(setq min-code code)
(if (> code max-code)
(setq max-code code)))
(search-forward "ENDCHAR")
(if (< maxlen (- (point) offset))
(setq maxlen (- (point) offset)))
(setq glyph-list (cons (cons code offset) glyph-list)))
(setq code-range
(vector min-code0 max-code0 min-code1 max-code1
min-code max-code (or default-char min-code)))
(setq offset-vector
(make-vector (1+ (bdf-compact-code max-code code-range))
nil))
(while glyph-list
(let ((glyph (car glyph-list)))
(aset offset-vector
(bdf-compact-code (car glyph) code-range)
(cdr glyph)))
(setq glyph-list (cdr glyph-list)))))
(kill-buffer buf))
(message "Reading %s...done" bdfname)
(list bdfname absolute-path (bdf-file-mod-time absolute-path)
size font-bounding-box relative-compose baseline-offset
code-range maxlen offset-vector)))
(defsubst bdf-info-absolute-path (font-info) (nth 1 font-info))
(defsubst bdf-info-mod-time (font-info) (nth 2 font-info))
(defsubst bdf-info-size (font-info) (nth 3 font-info))
(defsubst bdf-info-font-bounding-box (font-info) (nth 4 font-info))
(defsubst bdf-info-relative-compose (font-info) (nth 5 font-info))
(defsubst bdf-info-baseline-offset (font-info) (nth 6 font-info))
(defsubst bdf-info-code-range (font-info) (nth 7 font-info))
(defsubst bdf-info-maxlen (font-info) (nth 8 font-info))
(defsubst bdf-info-offset-vector (font-info) (nth 9 font-info))
(defun bdf-get-font-info (bdfname)
"Return information about `BDF' font file BDFNAME.
The value FONT-INFO is a list of the following format:
(BDFFILE ABSOLUTE-PATH MOD-TIME SIZE FONT-BOUNDING-BOX
RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
See the documentation of the function `bdf-read-font-info' for more detail."
(or bdf-cache
(bdf-read-cache))
(let ((font-info (assoc bdfname bdf-cache)))
(if (or (not font-info)
(not (file-readable-p (bdf-info-absolute-path font-info)))
(bdf-file-newer-than-time bdfname (bdf-info-mod-time font-info)))
(progn
(setq font-info (bdf-read-font-info bdfname))
(bdf-set-cache font-info)))
font-info))
(defun bdf-read-bitmap (bdfname offset maxlen)
"Read `BDF' font file BDFNAME to get bitmap data at file poistion OFFSET.
BDFNAME is an abosolute path name of the font file.
MAXLEN specifies how many bytes we should read at least.
The value is a list of DWIDTH, BBX, and BITMAP-STRING.
DWIDTH is a pixel width of a glyph.
BBX is a bounding box of the glyph.
BITMAP-STRING is a string representing bits by hexadecimal digits."
(let ((coding-system-for-read 'no-conversion)
dwidth bbx height yoff bitmap-string)
(condition-case nil
(with-temp-buffer
(insert-file-contents bdfname nil offset (+ offset maxlen))
(goto-char (point-min))
(search-forward "\nDWIDTH")
(setq dwidth (read (current-buffer)))
(goto-char (point-min))
(search-forward "\nBBX")
(setq bbx (vector (read (current-buffer)) (read (current-buffer))
(read (current-buffer)) (read (current-buffer))))
(setq height (aref bbx 1) yoff (aref bbx 3))
(search-forward "\nBITMAP")
(forward-line 1)
(delete-region (point-min) (point))
(if (looking-at "\\(0+\n\\)+")
(progn
(setq height
(- height (count-lines (point) (match-end 0))))
(delete-region (point) (match-end 0))))
(or (looking-at "ENDCHAR")
(progn
(search-forward "ENDCHAR" nil 'move)
(forward-line -1)
(while (looking-at "0+$")
(setq yoff (1+ yoff) height (1- height))
(forward-line -1))
(forward-line 1)))
(aset bbx 1 height)
(aset bbx 3 yoff)
(delete-region (point) (point-max))
(goto-char (point-min))
(while (not (eobp))
(end-of-line)
(delete-char 1))
(setq bitmap-string (buffer-string)))
(error nil))
(list dwidth bbx bitmap-string)))
(defun bdf-get-bitmaps (bdfname codes)
"Return bitmap information of glyphs of CODES in `BDF' font file BDFNAME.
CODES is a list of encoding number of glyphs in the file.
The value is a list of CODE, DWIDTH, BBX, and BITMAP-STRING.
DWIDTH is a pixel width of a glyph.
BBX is a bounding box of the glyph.
BITMAP-STRING is a string representing bits by hexadecimal digits."
(let* ((font-info (bdf-get-font-info bdfname))
(absolute-path (bdf-info-absolute-path font-info))
(font-bounding-box (bdf-info-font-bounding-box font-info))
(maxlen (bdf-info-maxlen font-info))
(code-range (bdf-info-code-range font-info))
(offset-vector (bdf-info-offset-vector font-info)))
(mapcar (function
(lambda (x)
(cons x (bdf-read-bitmap
absolute-path
(aref offset-vector (bdf-compact-code x code-range))
maxlen))))
codes)))
;;; Interface to ps-print.el
;; Called from ps-mule-init-external-library.
(defun bdf-generate-prologue ()
(or bdf-cache
(bdf-initialize))
(ps-mule-generate-bitmap-prologue))
;; Called from ps-mule-generate-font.
(defun bdf-generate-font (charset font-spec)
(let* ((font-name (ps-mule-font-spec-name font-spec))
(font-info (bdf-get-font-info font-name)))
(ps-mule-generate-bitmap-font font-name
(ps-mule-font-spec-bytes font-spec)
(charset-width charset)
(bdf-info-size font-info)
(bdf-info-relative-compose font-info)
(bdf-info-baseline-offset font-info)
(bdf-info-font-bounding-box font-info))))
;; Called from ps-mule-generate-glyphs.
(defun bdf-generate-glyphs (font-spec code-list bytes)
(let ((font-name (ps-mule-font-spec-name font-spec)))
(mapcar (function
(lambda (x)
(apply 'ps-mule-generate-bitmap-glyph font-name x)))
(bdf-get-bitmaps font-name code-list))))
(provide 'bdf)
;;; bdf.el ends here

296
lisp/docref.el
View file

@ -1,296 +0,0 @@
;;; docref.el --- Simple cross references for Elisp documentation strings
;; Copyright (C) 1994 Free Software Foundation, Inc.
;; Author: Vadim Geshel <vadik@unas.cs.kiev.ua>
;; Created: 12 Jul 1994
;; Keywords: docs, help, lisp
;; original name was cross-ref.el.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This package allows you to use a simple form of cross references in
;; your Emacs Lisp documentation strings. Cross-references look like
;; \\(type@[label@]data), where type defines a method for retrieving
;; reference information, data is used by a method routine as an argument,
;; and label "represents" the reference in text. If label is absent, data
;; is used instead.
;;
;; Special reference labeled `back', when present, can be used to return
;; to the previous contents of help buffer.
;;
;; Cross-referencing currently is intended for use in doc strings only
;; and works only in temporary buffers (created by `with-output-to-temp-buffer').
;; List of temp buffers in which cross-referencing is to be active is specified
;; by variable DOCREF-BUFFERS-LIST, which contains only "*Help*" by default.
;;
;; Documentation strings for this package's functions and variables can serve
;; as examples of usage.
;;
;;; Customization:
;;
;; See source. The main customization variable is `docref-methods-alist'.
;; It consists of (type . function) pairs, where type is a string which
;; corresponds to type in cross-references and function is called with
;; one argument - reference `data' - when a reference is activated.
;;
;;; Installation:
;;
;; Place this file somewhere in your load-path, byte-compiled it, and add
;; (require 'cross-ref)
;; to your .emacs.
;;; Code:
;; User customizable variables
(defgroup docref nil
"Simple cross references for Elisp documentation strings."
:prefix "docref-"
:group 'help
:group 'lisp
:group 'docs)
(defcustom docref-highlight-p t
"*If non-nil, \\(f@docref-subst) highlights cross-references.
Under window system it highlights them with face defined by
\\(v@docref-highlight-face), on character terminal highlighted references
look like cross-references in info mode."
:type 'boolean
:group 'docref)
(defcustom docref-highlight-face 'highlight
"*Face used to highlight cross-references (used by \\(f@docref-subst))"
:type 'face
:group 'docref)
(defcustom docref-methods-alist
'(("f" . docref-describe-function) ; reference to a function documentation
("v" . docref-describe-variable) ; reference to a variable documentation
("F" . docref-read-file) ; reference to a file contents
("s" . docref-use-string) ; reference to a string
("V" . docref-use-variable-value) ; reference to variable value
("0" . beep)) ; just highlighted text
"Alist which maps cross-reference ``types'' to retrieval functions.
The car of each element is a string that serves as `type' in cross-references.
\(See \\(f@docref-subst)). The cdr is a function of one argument,
to be called to find this reference."
:type '(repeat (cons string function))
:group 'docref)
(defcustom docref-back-label "\nback"
"Label to use by \\(f@docref-subst) for the go-back reference."
:type 'string
:group 'docref)
(defvar docref-back-reference nil
"If non-nil, this is a go-back reference to add to the current buffer.
The value specifies how to go back. It should be suitable for use
as the second argument to \\(f@docref-insert-label).
\\(f@docref-subst) uses this to set up the go-back reference.")
(defvar docref-last-active-buffer)
;;;###autoload
(defun docref-setup ()
"Process docref cross-references in the current buffer.
See also \\(f@docref-subst)."
(interactive)
(docref-subst (current-buffer))
(docref-mode))
(defvar docref-mode-map nil)
(or docref-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [mouse-2] 'docref-follow-mouse)
(define-key map "\C-c\C-b" 'docref-go-back)
(define-key map "\C-c\C-c" 'docref-follow)
(setq docref-mode-map map)))
(defun docref-mode ()
"Major mode for help buffers that contain cross references.
To follow a reference, move to it and type \\[docref-follow], or use
\\[docref-follow-mouse]. The command \\[docref-go-back] can used to go
back to where you came from."
(interactive)
(kill-all-local-variables)
(setq major-mode 'docref-mode)
(setq mode-name "Docref")
(use-local-map docref-mode-map)
(run-hooks 'docref-mode))
(defun docref-subst (buf)
"Parse documentation cross-references in buffer BUF.
Find cross-reference information in a buffer and
highlight them with face defined by \\(v@docref-highlight-face).
Cross-reference has the following format: \\ (TYPE[@LABEL]@DATA), where
TYPE defines method used to retrieve xref data (like reading from file or
calling \\(f@describe-function)), DATA is an argument to this method
\(like file name or function name), and LABEL is displayed in text using
\\(v@docref-highlight-face).
The special reference `back' can be used to return back.
The variable \\(v@docref-back-label) specifies the label to use for that.
See \\(v@docref-methods-alist) for currently defined methods."
(interactive "b")
(save-excursion
(set-buffer buf)
(goto-char (point-min))
;; The docref-seen property indicates that we have processed this
;; buffer's contents already, so don't do it again.
(if (not (get-text-property (point-min) 'docref-seen))
(let ((old-modified (buffer-modified-p)))
(while (re-search-forward "[\\](\\([^\)\@]+\\)\\(@[^\)\@]+\\)?@\\([^\)]*\\))"
nil t)
(let* ((start (match-beginning 0))
(type (buffer-substring (match-beginning 1) (match-end 1)))
(data (buffer-substring (match-beginning 3) (match-end 3)))
(label
(if (match-beginning 2)
(buffer-substring (+ (match-beginning 2) 1) (match-end 2))
data)))
(replace-match "" t)
(docref-insert-label label (cons type data))))
;; Make a back-reference in this buffer, if desired.
;; (This is true if called from docref-follow.)
(if docref-back-reference
(progn
(goto-char (point-max))
(put-text-property (point-min) (1+ (point-min))
'docref-back-position (point))
(docref-insert-label docref-back-label docref-back-reference)))
(put-text-property (point-min) (1+ (point-min)) 'docref-seen t)
(set-buffer-modified-p old-modified)))))
(defun docref-insert-label (string ref)
(let ((label (concat string))
(pos (point)))
;; decorate the label
(let ((leading-space-end (save-match-data
(if (string-match "^\\([ \t\n]+\\)" label)
(match-end 1)
0)))
(trailing-space-start (save-match-data
(if (string-match "\\([ \t\n]+\\)$" label)
(match-beginning 1)
(length label)))))
(if docref-highlight-p
(if (not window-system)
(setq label
(concat (substring label 0 leading-space-end)
"(*note "
(substring label leading-space-end trailing-space-start)
")"
(substring label trailing-space-start)))
;; window-system
(put-text-property leading-space-end
trailing-space-start
'face docref-highlight-face label)))
(put-text-property 0 (length label) 'docref ref label)
(insert label))))
(defun docref-follow-mouse (click)
"Follow the cross-reference that you click on."
(interactive "e")
(save-excursion
(let* ((start (event-start click))
(window (car start))
(pos (car (cdr start)))
(docref-last-active-buffer (current-buffer)))
(set-buffer (window-buffer window))
(docref-follow pos))))
(defun docref-go-back ()
"Go back to the previous contents of help buffer."
(interactive)
(let ((pos (get-text-property (point-min) 'docref-back-position)))
(if pos
(docref-follow pos)
(error "No go-back reference"))))
(defun docref-follow (&optional pos)
"Follow cross-reference at point.
For the cross-reference format, see \\(f@docref-subst).
The special reference named `back' can be used to return back"
(interactive)
(or pos (setq pos (point)))
(let ((docref-data (get-text-property pos 'docref)))
(if docref-data
;; There is a reference at point. Follow it.
(let* ((type (car docref-data))
(name (cdr docref-data))
(method (assoc type docref-methods-alist))
(cur-contents (buffer-string))
(opoint (point))
(docref-back-reference (cons "s" cur-contents))
success)
(if (null method)
(error "Unknown cross-reference type: %s" type))
(unwind-protect
(save-excursion
(funcall (cdr method) name)
(setq success t))
(or success
(progn
;; (cdr method) got an error.
;; Put back the text that we had.
(erase-buffer)
(insert cur-contents)
(goto-char opoint)))
(set-buffer-modified-p nil))))))
;; Builtin methods for accessing a reference.
(defun docref-describe-function (data)
(save-excursion
(if (boundp 'docref-last-active-buffer)
(set-buffer docref-last-active-buffer))
(describe-function (intern data))))
(defun docref-describe-variable (data)
(save-excursion
(if (boundp 'docref-last-active-buffer)
(set-buffer docref-last-active-buffer))
(describe-variable (intern data))))
(defun docref-read-file (data)
(with-output-to-temp-buffer (buffer-name)
(erase-buffer)
(insert-file-contents (expand-file-name data))))
(defun docref-use-string (data)
(with-output-to-temp-buffer (buffer-name)
(erase-buffer)
(insert data)))
(defun docref-use-variable-value (data)
(let ((sym (intern data)))
(with-output-to-temp-buffer (buffer-name)
(erase-buffer)
(princ (symbol-value sym)))))
(provide 'docref)
;;; docref.el ends here

170
lisp/dos-win32.el
View file

@ -1,170 +0,0 @@
;;; dos-win32.el --- Functions shared among MS-DOS and Win32 (NT/95) platforms
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Maintainer: Geoff Voelker (voelker@cs.washington.edu)
;; Keywords: internal
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Parts of this code are duplicated functions taken from dos-fns.el
;; and winnt.el.
;;; Code:
;;; Add %t: into the mode line format just after the open-paren.
(let ((tail (member " %[(" mode-line-format)))
(setcdr tail (cons (purecopy "%t:")
(cdr tail))))
;; Use ";" instead of ":" as a path separator (from files.el).
(setq path-separator ";")
;; Set the null device (for compile.el).
(setq grep-null-device "NUL")
;; Set the grep regexp to match entries with drive letters.
(setq grep-regexp-alist
'(("^\\(\\([a-zA-Z]:\\)?[^:( \t\n]+\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 3)))
;; For distinguishing file types based upon suffixes.
(defvar file-name-buffer-file-type-alist
'(
("[:/].*config.sys$" . nil) ; config.sys text
("\\.elc$" . t) ; emacs stuff
("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\)$" . t)
; MS-Dos stuff
("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t)
; Packers
("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\)$" . t)
; Unix stuff
("\\.tp[ulpw]$" . t)
; Borland Pascal stuff
("[:/]tags$" . t)
; Emacs TAGS file
)
"*Alist for distinguishing text files from binary files.
Each element has the form (REGEXP . TYPE), where REGEXP is matched
against the file name, and TYPE is nil for text, t for binary.")
(defun find-buffer-file-type (filename)
;; First check if file is on an untranslated filesystem, then on the alist.
(if (untranslated-file-p filename)
t ; for binary
(let ((alist file-name-buffer-file-type-alist)
(found nil)
(code nil))
(let ((case-fold-search t))
(setq filename (file-name-sans-versions filename))
(while (and (not found) alist)
(if (string-match (car (car alist)) filename)
(setq code (cdr (car alist))
found t))
(setq alist (cdr alist))))
(if found
(cond ((memq code '(nil t)) code)
((and (symbolp code) (fboundp code))
(funcall code filename)))
default-buffer-file-type))))
(defun find-file-binary (filename)
"Visit file FILENAME and treat it as binary."
(interactive "FFind file binary: ")
(let ((file-name-buffer-file-type-alist '(("" . t))))
(find-file filename)))
(defun find-file-text (filename)
"Visit file FILENAME and treat it as a text file."
(interactive "FFind file text: ")
(let ((file-name-buffer-file-type-alist '(("" . nil))))
(find-file filename)))
(defun find-file-not-found-set-buffer-file-type ()
(save-excursion
(set-buffer (current-buffer))
(setq buffer-file-type (find-buffer-file-type (buffer-file-name))))
nil)
;;; To set the default file type on new files.
(add-hook 'find-file-not-found-hooks 'find-file-not-found-set-buffer-file-type)
;;; To accomodate filesystems that do not require CR/LF translation.
(defvar untranslated-filesystem-list nil
"List of filesystems that require no CR/LF translation during file I/O.
Each element in the list is a string naming the directory prefix
corresponding to the filesystem.")
(defun untranslated-canonical-name (filename)
"Return FILENAME in a canonicalized form.
This is for use with the functions dealing with untranslated filesystems."
(if (memq system-type '(ms-dos windows-nt))
;; The canonical form for DOS/NT/Win95 is with A-Z downcased and all
;; directory separators changed to directory-sep-char.
(let ((name nil))
(setq name (mapconcat
'(lambda (char)
(if (and (<= ?A char) (<= char ?Z))
(char-to-string (+ (- char ?A) ?a))
(char-to-string char)))
filename nil))
;; Use expand-file-name to canonicalize directory separators, except
;; with bare drive letters (which would have the cwd appended).
(if (string-match "^.:$" name)
name
(expand-file-name name)))
filename))
(defun untranslated-file-p (filename)
"Test whether CR/LF translation should be disabled for FILENAME.
Return t if FILENAME is on a filesystem that does not require
CR/LF translation, and nil otherwise."
(let ((fs (untranslated-canonical-name filename))
(ufs-list untranslated-filesystem-list)
(found nil))
(while (and (not found) ufs-list)
(if (string-match (concat "^" (regexp-quote (car ufs-list))) fs)
(setq found t)
(setq ufs-list (cdr ufs-list))))
found))
(defun add-untranslated-filesystem (filesystem)
"Record that FILESYSTEM does not require CR/LF translation.
FILESYSTEM is a string containing the directory prefix corresponding to
the filesystem. For example, for a Unix filesystem mounted on drive Z:,
FILESYSTEM could be \"Z:\"."
(let ((fs (untranslated-canonical-name filesystem)))
(if (member fs untranslated-filesystem-list)
untranslated-filesystem-list
(setq untranslated-filesystem-list
(cons fs untranslated-filesystem-list)))))
(defun remove-untranslated-filesystem (filesystem)
"Record that FILESYSTEM requires CR/LF translation.
FILESYSTEM is a string containing the directory prefix corresponding to
the filesystem. For example, for a Unix filesystem mounted on drive Z:,
FILESYSTEM could be \"Z:\"."
(setq untranslated-filesystem-list
(delete (untranslated-canonical-name filesystem)
untranslated-filesystem-list)))
(provide 'dos-win32)
;;; dos-win32.el ends here

623
lisp/gnus-cache.el
View file

@ -1,623 +0,0 @@
;;; gnus-cache.el --- cache interface for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-cache-directory
(nnheader-concat gnus-directory "cache/")
"*The directory where cached articles will be stored.")
(defvar gnus-cache-active-file
(concat (file-name-as-directory gnus-cache-directory) "active")
"*The cache active file.")
(defvar gnus-cache-enter-articles '(ticked dormant)
"*Classes of articles to enter into the cache.")
(defvar gnus-cache-remove-articles '(read)
"*Classes of articles to remove from the cache.")
(defvar gnus-uncacheable-groups nil
"*Groups that match this regexp will not be cached.
If you want to avoid caching your nnml groups, you could set this
variable to \"^nnml\".")
;;; Internal variables.
(defvar gnus-cache-buffer nil)
(defvar gnus-cache-active-hashtb nil)
(defvar gnus-cache-active-altered nil)
(eval-and-compile
(autoload 'nnml-generate-nov-databases-1 "nnml")
(autoload 'nnvirtual-find-group-art "nnvirtual"))
;;; Functions called from Gnus.
(defun gnus-cache-open ()
"Initialize the cache."
(when (or (file-exists-p gnus-cache-directory)
(and gnus-use-cache
(not (eq gnus-use-cache 'passive))))
(gnus-cache-read-active)))
(condition-case ()
(gnus-add-shutdown 'gnus-cache-close 'gnus)
;; Complexities of byte-compiling makes this kludge necessary. Eeek.
(error nil))
(defun gnus-cache-close ()
"Shut down the cache."
(gnus-cache-write-active)
(gnus-cache-save-buffers)
(setq gnus-cache-active-hashtb nil))
(defun gnus-cache-save-buffers ()
;; save the overview buffer if it exists and has been modified
;; delete empty cache subdirectories
(if (null gnus-cache-buffer)
()
(let ((buffer (cdr gnus-cache-buffer))
(overview-file (gnus-cache-file-name
(car gnus-cache-buffer) ".overview")))
;; write the overview only if it was modified
(if (buffer-modified-p buffer)
(save-excursion
(set-buffer buffer)
(if (> (buffer-size) 0)
;; non-empty overview, write it out
(progn
(gnus-make-directory (file-name-directory overview-file))
(write-region (point-min) (point-max)
overview-file nil 'quietly))
;; empty overview file, remove it
(and (file-exists-p overview-file)
(delete-file overview-file))
;; if possible, remove group's cache subdirectory
(condition-case nil
;; FIXME: we can detect the error type and warn the user
;; of any inconsistencies (articles w/o nov entries?).
;; for now, just be conservative...delete only if safe -- sj
(delete-directory (file-name-directory overview-file))
(error nil)))))
;; kill the buffer, it's either unmodified or saved
(gnus-kill-buffer buffer)
(setq gnus-cache-buffer nil))))
(defun gnus-cache-possibly-enter-article
(group article headers ticked dormant unread &optional force)
(when (and (or force (not (eq gnus-use-cache 'passive)))
(numberp article)
(> article 0)
(vectorp headers)) ; This might be a dummy article.
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
(gnus-group-real-name group) article)))
(setq group (car result)
headers (copy-sequence headers))
(mail-header-set-number headers (cdr result))))
(let ((number (mail-header-number headers))
file dir)
(when (and (> number 0) ; Reffed article.
(or (not gnus-uncacheable-groups)
(not (string-match gnus-uncacheable-groups group)))
(or force
(gnus-cache-member-of-class
gnus-cache-enter-articles ticked dormant unread))
(not (file-exists-p (setq file (gnus-cache-file-name
group number)))))
;; Possibly create the cache directory.
(or (file-exists-p (setq dir (file-name-directory file)))
(gnus-make-directory dir))
;; Save the article in the cache.
(if (file-exists-p file)
t ; The article already is saved.
(save-excursion
(set-buffer nntp-server-buffer)
(let ((gnus-use-cache nil))
(gnus-request-article-this-buffer number group))
(when (> (buffer-size) 0)
(write-region (point-min) (point-max) file nil 'quiet)
(gnus-cache-change-buffer group)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-max))
(forward-line -1)
(while (condition-case ()
(and (not (bobp))
(> (read (current-buffer)) number))
(error
;; The line was malformed, so we just remove it!!
(gnus-delete-line)
t))
(forward-line -1))
(if (bobp)
(if (not (eobp))
(progn
(beginning-of-line)
(if (< (read (current-buffer)) number)
(forward-line 1)))
(beginning-of-line))
(forward-line 1))
(beginning-of-line)
;; [number subject from date id references chars lines xref]
(insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
(mail-header-number headers)
(mail-header-subject headers)
(mail-header-from headers)
(mail-header-date headers)
(mail-header-id headers)
(or (mail-header-references headers) "")
(or (mail-header-chars headers) "")
(or (mail-header-lines headers) "")
(or (mail-header-xref headers) "")))
;; Update the active info.
(set-buffer gnus-summary-buffer)
(gnus-cache-update-active group number)
(push article gnus-newsgroup-cached)
(gnus-summary-update-secondary-mark article))
t))))))
(defun gnus-cache-enter-remove-article (article)
"Mark ARTICLE for later possible removal."
(when article
(push article gnus-cache-removable-articles)))
(defun gnus-cache-possibly-remove-articles ()
"Possibly remove some of the removable articles."
(if (not (gnus-virtual-group-p gnus-newsgroup-name))
(gnus-cache-possibly-remove-articles-1)
(let ((arts gnus-cache-removable-articles)
ga)
(while arts
(when (setq ga (nnvirtual-find-group-art
(gnus-group-real-name gnus-newsgroup-name) (pop arts)))
(let ((gnus-cache-removable-articles (list (cdr ga)))
(gnus-newsgroup-name (car ga)))
(gnus-cache-possibly-remove-articles-1)))))
(setq gnus-cache-removable-articles nil)))
(defun gnus-cache-possibly-remove-articles-1 ()
"Possibly remove some of the removable articles."
(unless (eq gnus-use-cache 'passive)
(let ((articles gnus-cache-removable-articles)
(cache-articles gnus-newsgroup-cached)
article)
(gnus-cache-change-buffer gnus-newsgroup-name)
(while articles
(if (memq (setq article (pop articles)) cache-articles)
;; The article was in the cache, so we see whether we are
;; supposed to remove it from the cache.
(gnus-cache-possibly-remove-article
article (memq article gnus-newsgroup-marked)
(memq article gnus-newsgroup-dormant)
(or (memq article gnus-newsgroup-unreads)
(memq article gnus-newsgroup-unselected))))))
;; The overview file might have been modified, save it
;; safe because we're only called at group exit anyway.
(gnus-cache-save-buffers)))
(defun gnus-cache-request-article (article group)
"Retrieve ARTICLE in GROUP from the cache."
(let ((file (gnus-cache-file-name group article))
(buffer-read-only nil))
(when (file-exists-p file)
(erase-buffer)
(gnus-kill-all-overlays)
(insert-file-contents file)
t)))
(defun gnus-cache-possibly-alter-active (group active)
"Alter the ACTIVE info for GROUP to reflect the articles in the cache."
(when gnus-cache-active-hashtb
(let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
(and cache-active
(< (car cache-active) (car active))
(setcar active (car cache-active)))
(and cache-active
(> (cdr cache-active) (cdr active))
(setcdr active (cdr cache-active))))))
(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
"Retrieve the headers for ARTICLES in GROUP."
(let ((cached
(setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
(if (not cached)
;; No cached articles here, so we just retrieve them
;; the normal way.
(let ((gnus-use-cache nil))
(gnus-retrieve-headers articles group fetch-old))
(let ((uncached-articles (gnus-sorted-intersection
(gnus-sorted-complement articles cached)
articles))
(cache-file (gnus-cache-file-name group ".overview"))
type)
;; We first retrieve all the headers that we don't have in
;; the cache.
(let ((gnus-use-cache nil))
(when uncached-articles
(setq type (and articles
(gnus-retrieve-headers
uncached-articles group fetch-old)))))
(gnus-cache-save-buffers)
;; Then we insert the cached headers.
(save-excursion
(cond
((not (file-exists-p cache-file))
;; There are no cached headers.
type)
((null type)
;; There were no uncached headers (or retrieval was
;; unsuccessful), so we use the cached headers exclusively.
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-file-contents cache-file)
'nov)
((eq type 'nov)
;; We have both cached and uncached NOV headers, so we
;; braid them.
(gnus-cache-braid-nov group cached)
type)
(t
;; We braid HEADs.
(gnus-cache-braid-heads group (gnus-sorted-intersection
cached articles))
type)))))))
(defun gnus-cache-enter-article (&optional n)
"Enter the next N articles into the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles entered."
(interactive "P")
(gnus-set-global-variables)
(let ((articles (gnus-summary-work-articles n))
article out)
(while articles
(setq article (pop articles))
(when (gnus-cache-possibly-enter-article
gnus-newsgroup-name article (gnus-summary-article-header article)
nil nil nil t)
(push article out))
(gnus-summary-remove-process-mark article)
(gnus-summary-update-secondary-mark article))
(gnus-summary-next-subject 1)
(gnus-summary-position-point)
(nreverse out)))
(defun gnus-cache-remove-article (n)
"Remove the next N articles from the cache.
If not given a prefix, use the process marked articles instead.
Returns the list of articles removed."
(interactive "P")
(gnus-set-global-variables)
(gnus-cache-change-buffer gnus-newsgroup-name)
(let ((articles (gnus-summary-work-articles n))
article out)
(while articles
(setq article (pop articles))
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(push article out))
(gnus-summary-remove-process-mark article)
(gnus-summary-update-secondary-mark article))
(gnus-summary-next-subject 1)
(gnus-summary-position-point)
(nreverse out)))
(defun gnus-cached-article-p (article)
"Say whether ARTICLE is cached in the current group."
(memq article gnus-newsgroup-cached))
;;; Internal functions.
(defun gnus-cache-change-buffer (group)
(and gnus-cache-buffer
;; See if the current group's overview cache has been loaded.
(or (string= group (car gnus-cache-buffer))
;; Another overview cache is current, save it.
(gnus-cache-save-buffers)))
;; if gnus-cache buffer is nil, create it
(or gnus-cache-buffer
;; Create cache buffer
(save-excursion
(setq gnus-cache-buffer
(cons group
(set-buffer (get-buffer-create " *gnus-cache-overview*"))))
(buffer-disable-undo (current-buffer))
;; Insert the contents of this group's cache overview.
(erase-buffer)
(let ((file (gnus-cache-file-name group ".overview")))
(and (file-exists-p file)
(insert-file-contents file)))
;; We have a fresh (empty/just loaded) buffer,
;; mark it as unmodified to save a redundant write later.
(set-buffer-modified-p nil))))
;; Return whether an article is a member of a class.
(defun gnus-cache-member-of-class (class ticked dormant unread)
(or (and ticked (memq 'ticked class))
(and dormant (memq 'dormant class))
(and unread (memq 'unread class))
(and (not unread) (not ticked) (not dormant) (memq 'read class))))
(defun gnus-cache-file-name (group article)
(concat (file-name-as-directory gnus-cache-directory)
(file-name-as-directory
(if (gnus-use-long-file-name 'not-cache)
group
(let ((group (concat group "")))
(if (string-match ":" group)
(aset group (match-beginning 0) ?/))
(nnheader-replace-chars-in-string group ?. ?/))))
(if (stringp article) article (int-to-string article))))
(defun gnus-cache-update-article (group article)
"If ARTICLE is in the cache, remove it and re-enter it."
(when (gnus-cache-possibly-remove-article article nil nil nil t)
(let ((gnus-use-cache nil))
(gnus-cache-possibly-enter-article
gnus-newsgroup-name article (gnus-summary-article-header article)
nil nil nil t))))
(defun gnus-cache-possibly-remove-article (article ticked dormant unread
&optional force)
"Possibly remove ARTICLE from the cache."
(let ((group gnus-newsgroup-name)
(number article)
file)
;; If this is a virtual group, we find the real group.
(when (gnus-virtual-group-p group)
(let ((result (nnvirtual-find-group-art
(gnus-group-real-name group) article)))
(setq group (car result)
number (cdr result))))
(setq file (gnus-cache-file-name group number))
(when (and (file-exists-p file)
(or force
(gnus-cache-member-of-class
gnus-cache-remove-articles ticked dormant unread)))
(save-excursion
(delete-file file)
(set-buffer (cdr gnus-cache-buffer))
(goto-char (point-min))
(if (or (looking-at (concat (int-to-string number) "\t"))
(search-forward (concat "\n" (int-to-string number) "\t")
(point-max) t))
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point)))))
(setq gnus-newsgroup-cached
(delq article gnus-newsgroup-cached))
(gnus-summary-update-secondary-mark article)
t)))
(defun gnus-cache-articles-in-group (group)
"Return a sorted list of cached articles in GROUP."
(let ((dir (file-name-directory (gnus-cache-file-name group 1)))
articles)
(when (file-exists-p dir)
(sort (mapcar (lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))
'<))))
(defun gnus-cache-braid-nov (group cached)
(let ((cache-buf (get-buffer-create " *gnus-cache*"))
beg end)
(gnus-cache-save-buffers)
(save-excursion
(set-buffer cache-buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-file-contents (gnus-cache-file-name group ".overview"))
(goto-char (point-min))
(insert "\n")
(goto-char (point-min)))
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(while cached
(while (and (not (eobp))
(< (read (current-buffer)) (car cached)))
(forward-line 1))
(beginning-of-line)
(save-excursion
(set-buffer cache-buf)
(if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
nil t)
(setq beg (progn (beginning-of-line) (point))
end (progn (end-of-line) (point)))
(setq beg nil)))
(if beg (progn (insert-buffer-substring cache-buf beg end)
(insert "\n")))
(setq cached (cdr cached)))
(kill-buffer cache-buf)))
(defun gnus-cache-braid-heads (group cached)
(let ((cache-buf (get-buffer-create " *gnus-cache*")))
(save-excursion
(set-buffer cache-buf)
(buffer-disable-undo (current-buffer))
(erase-buffer))
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(while cached
(while (and (not (eobp))
(looking-at "2.. +\\([0-9]+\\) ")
(< (progn (goto-char (match-beginning 1))
(read (current-buffer)))
(car cached)))
(search-forward "\n.\n" nil 'move))
(beginning-of-line)
(save-excursion
(set-buffer cache-buf)
(erase-buffer)
(insert-file-contents (gnus-cache-file-name group (car cached)))
(goto-char (point-min))
(insert "220 ")
(princ (car cached) (current-buffer))
(insert " Article retrieved.\n")
(search-forward "\n\n" nil 'move)
(delete-region (point) (point-max))
(forward-char -1)
(insert "."))
(insert-buffer-substring cache-buf)
(setq cached (cdr cached)))
(kill-buffer cache-buf)))
;;;###autoload
(defun gnus-jog-cache ()
"Go through all groups and put the articles into the cache."
(interactive)
(let ((gnus-mark-article-hook nil)
(gnus-expert-user t)
(nnmail-spool-file nil)
(gnus-use-dribble-file nil)
(gnus-novice-user nil)
(gnus-large-newsgroup nil))
;; Start Gnus.
(gnus)
;; Go through all groups...
(gnus-group-mark-buffer)
(gnus-group-universal-argument
nil nil
(lambda ()
(gnus-summary-read-group nil nil t)
;; ... and enter the articles into the cache.
(when (eq major-mode 'gnus-summary-mode)
(gnus-uu-mark-buffer)
(gnus-cache-enter-article)
(kill-buffer (current-buffer)))))))
(defun gnus-cache-read-active (&optional force)
"Read the cache active file."
(unless (file-exists-p gnus-cache-directory)
(make-directory gnus-cache-directory t))
(if (not (and (file-exists-p gnus-cache-active-file)
(or force (not gnus-cache-active-hashtb))))
;; There is no active file, so we generate one.
(gnus-cache-generate-active)
;; We simply read the active file.
(save-excursion
(gnus-set-work-buffer)
(insert-file-contents gnus-cache-active-file)
(gnus-active-to-gnus-format
nil (setq gnus-cache-active-hashtb
(gnus-make-hashtable
(count-lines (point-min) (point-max)))))
(setq gnus-cache-active-altered nil))))
(defun gnus-cache-write-active (&optional force)
"Write the active hashtb to the active file."
(when (or force
(and gnus-cache-active-hashtb
gnus-cache-active-altered))
(save-excursion
(gnus-set-work-buffer)
(mapatoms
(lambda (sym)
(when (and sym (boundp sym))
(insert (format "%s %d %d y\n"
(symbol-name sym) (cdr (symbol-value sym))
(car (symbol-value sym))))))
gnus-cache-active-hashtb)
(gnus-make-directory (file-name-directory gnus-cache-active-file))
(write-region
(point-min) (point-max) gnus-cache-active-file nil 'silent))
;; Mark the active hashtb as unaltered.
(setq gnus-cache-active-altered nil)))
(defun gnus-cache-update-active (group number &optional low)
"Update the upper bound of the active info of GROUP to NUMBER.
If LOW, update the lower bound instead."
(let ((active (gnus-gethash group gnus-cache-active-hashtb)))
(if (null active)
;; We just create a new active entry for this group.
(gnus-sethash group (cons number number) gnus-cache-active-hashtb)
;; Update the lower or upper bound.
(if low
(setcar active number)
(setcdr active number))
;; Mark the active hashtb as altered.
(setq gnus-cache-active-altered t))))
;;;###autoload
(defun gnus-cache-generate-active (&optional directory)
"Generate the cache active file."
(interactive)
(let* ((top (null directory))
(directory (expand-file-name (or directory gnus-cache-directory)))
(files (directory-files directory 'full))
(group
(if top
""
(string-match
(concat "^" (file-name-as-directory
(expand-file-name gnus-cache-directory)))
(directory-file-name directory))
(nnheader-replace-chars-in-string
(substring (directory-file-name directory) (match-end 0))
?/ ?.)))
nums alphs)
(when top
(gnus-message 5 "Generating the cache active file...")
(setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
;; Separate articles from all other files and directories.
(while files
(if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
(push (string-to-int (file-name-nondirectory (pop files))) nums)
(push (pop files) alphs)))
;; If we have nums, then this is probably a valid group.
(when (setq nums (sort nums '<))
(gnus-sethash group (cons (car nums) (gnus-last-element nums))
gnus-cache-active-hashtb))
;; Go through all the other files.
(while alphs
(when (and (file-directory-p (car alphs))
(not (string-match "^\\.\\.?$"
(file-name-nondirectory (car alphs)))))
;; We descend directories.
(gnus-cache-generate-active (car alphs)))
(setq alphs (cdr alphs)))
;; Write the new active file.
(when top
(gnus-cache-write-active t)
(gnus-message 5 "Generating the cache active file...done"))))
;;;###autoload
(defun gnus-cache-generate-nov-databases (dir)
"Generate NOV files recursively starting in DIR."
(interactive (list gnus-cache-directory))
(gnus-cache-close)
(let ((nnml-generate-active-function 'identity))
(nnml-generate-nov-databases-1 dir)))
(provide 'gnus-cache)
;;; gnus-cache.el ends here

732
lisp/gnus-cite.el
View file

@ -1,732 +0,0 @@
;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(require 'gnus-msg)
(require 'gnus-ems)
(eval-when-compile (require 'cl))
(eval-and-compile
(autoload 'gnus-article-add-button "gnus-vis"))
;;; Customization:
(defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n"
"Format of cited text buttons.")
(defvar gnus-cited-lines-visible nil
"The number of lines of hidden cited text to remain visible.")
(defvar gnus-cite-parse-max-size 25000
"Maximum article size (in bytes) where parsing citations is allowed.
Set it to nil to parse all articles.")
(defvar gnus-cite-prefix-regexp
"^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
"Regexp matching the longest possible citation prefix on a line.")
(defvar gnus-cite-max-prefix 20
"Maximum possible length for a citation prefix.")
(defvar gnus-supercite-regexp
(concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
">>>>> +\"\\([^\"\n]+\\)\" +==")
"Regexp matching normal Supercite attribution lines.
The first grouping must match prefixes added by other packages.")
(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
"Regexp matching mangled Supercite attribution lines.
The first regexp group should match the Supercite attribution.")
(defvar gnus-cite-minimum-match-count 2
"Minimum number of identical prefixes before we believe it's a citation.")
;see gnus-cus.el
;(defvar gnus-cite-face-list
; (if (eq gnus-display-type 'color)
; (if (eq gnus-background-mode 'dark) 'light 'dark)
; '(italic))
; "Faces used for displaying different citations.
;It is either a list of face names, or one of the following special
;values:
;dark: Create faces from `gnus-face-dark-name-list'.
;light: Create faces from `gnus-face-light-name-list'.
;The variable `gnus-make-foreground' determines whether the created
;faces change the foreground or the background colors.")
(defvar gnus-cite-attribution-prefix "in article\\|in <"
"Regexp matching the beginning of an attribution line.")
(defvar gnus-cite-attribution-suffix
"\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
"Regexp matching the end of an attribution line.
The text matching the first grouping will be used as a button.")
;see gnus-cus.el
;(defvar gnus-cite-attribution-face 'underline
; "Face used for attribution lines.
;It is merged with the face for the cited text belonging to the attribution.")
;see gnus-cus.el
;(defvar gnus-cite-hide-percentage 50
; "Only hide cited text if it is larger than this percent of the body.")
;see gnus-cus.el
;(defvar gnus-cite-hide-absolute 10
; "Only hide cited text if there is at least this number of cited lines.")
;see gnus-cus.el
;(defvar gnus-face-light-name-list
; '("light blue" "light cyan" "light yellow" "light pink"
; "pale green" "beige" "orange" "magenta" "violet" "medium purple"
; "turquoise")
; "Names of light colors.")
;see gnus-cus.el
;(defvar gnus-face-dark-name-list
; '("dark salmon" "firebrick"
; "dark green" "dark orange" "dark khaki" "dark violet"
; "dark turquoise")
; "Names of dark colors.")
;;; Internal Variables:
(defvar gnus-cite-article nil)
(defvar gnus-cite-prefix-alist nil)
;; Alist of citation prefixes.
;; The cdr is a list of lines with that prefix.
(defvar gnus-cite-attribution-alist nil)
;; Alist of attribution lines.
;; The car is a line number.
;; The cdr is the prefix for the citation started by that line.
(defvar gnus-cite-loose-prefix-alist nil)
;; Alist of citation prefixes that have no matching attribution.
;; The cdr is a list of lines with that prefix.
(defvar gnus-cite-loose-attribution-alist nil)
;; Alist of attribution lines that have no matching citation.
;; Each member has the form (WROTE IN PREFIX TAG), where
;; WROTE: is the attribution line number
;; IN: is the line number of the previous line if part of the same attribution,
;; PREFIX: Is the citation prefix of the attribution line(s), and
;; TAG: Is a Supercite tag, if any.
(defvar gnus-cited-text-button-line-format-alist
`((?b beg ?d)
(?e end ?d)
(?l (- end beg) ?d)))
(defvar gnus-cited-text-button-line-format-spec nil)
;;; Commands:
(defun gnus-article-highlight-citation (&optional force)
"Highlight cited text.
Each citation in the article will be highlighted with a different face.
The faces are taken from `gnus-cite-face-list'.
Attribution lines are highlighted with the same face as the
corresponding citation merged with `gnus-cite-attribution-face'.
Text is considered cited if at least `gnus-cite-minimum-match-count'
lines matches `gnus-cite-prefix-regexp' with the same prefix.
Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
;; Create dark or light faces if necessary.
(cond ((eq gnus-cite-face-list 'light)
(setq gnus-cite-face-list
(mapcar 'gnus-make-face gnus-face-light-name-list)))
((eq gnus-cite-face-list 'dark)
(setq gnus-cite-face-list
(mapcar 'gnus-make-face gnus-face-dark-name-list))))
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
(alist gnus-cite-prefix-alist)
(faces gnus-cite-face-list)
(inhibit-point-motion-hooks t)
face entry prefix skip numbers number face-alist)
;; Loop through citation prefixes.
(while alist
(setq entry (car alist)
alist (cdr alist)
prefix (car entry)
numbers (cdr entry)
face (car faces)
faces (or (cdr faces) gnus-cite-face-list)
face-alist (cons (cons prefix face) face-alist))
(while numbers
(setq number (car numbers)
numbers (cdr numbers))
(and (not (assq number gnus-cite-attribution-alist))
(not (assq number gnus-cite-loose-attribution-alist))
(gnus-cite-add-face number prefix face))))
;; Loop through attribution lines.
(setq alist gnus-cite-attribution-alist)
(while alist
(setq entry (car alist)
alist (cdr alist)
number (car entry)
prefix (cdr entry)
skip (gnus-cite-find-prefix number)
face (cdr (assoc prefix face-alist)))
;; Add attribution button.
(goto-line number)
(if (re-search-forward gnus-cite-attribution-suffix
(save-excursion (end-of-line 1) (point))
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
'gnus-cite-toggle prefix))
;; Highlight attribution line.
(gnus-cite-add-face number skip face)
(gnus-cite-add-face number skip gnus-cite-attribution-face))
;; Loop through attribution lines.
(setq alist gnus-cite-loose-attribution-alist)
(while alist
(setq entry (car alist)
alist (cdr alist)
number (car entry)
skip (gnus-cite-find-prefix number))
(gnus-cite-add-face number skip gnus-cite-attribution-face)))))
(defun gnus-dissect-cited-text ()
"Dissect the article buffer looking for cited text."
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe)
(let ((alist gnus-cite-prefix-alist)
prefix numbers number marks m)
;; Loop through citation prefixes.
(while alist
(setq numbers (pop alist)
prefix (pop numbers))
(while numbers
(setq number (pop numbers))
(goto-char (point-min))
(forward-line number)
(push (cons (point-marker) "") marks)
(while (and numbers
(= (1- number) (car numbers)))
(setq number (pop numbers)))
(goto-char (point-min))
(forward-line (1- number))
(push (cons (point-marker) prefix) marks)))
(goto-char (point-min))
(search-forward "\n\n" nil t)
(push (cons (point-marker) "") marks)
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(push (cons (point-marker) "") marks)
(setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2)))))
(let* ((omarks marks))
(setq marks nil)
(while (cdr omarks)
(if (= (caar omarks) (caadr omarks))
(progn
(unless (equal (cdar omarks) "")
(push (car omarks) marks))
(unless (equal (cdadr omarks) "")
(push (cadr omarks) marks))
(setq omarks (cdr omarks)))
(push (car omarks) marks))
(setq omarks (cdr omarks)))
(when (car omarks)
(push (car omarks) marks))
(setq marks (setq m (nreverse marks)))
(while (cddr m)
(if (and (equal (cdadr m) "")
(equal (cdar m) (cdaddr m))
(goto-char (caadr m))
(forward-line 1)
(= (point) (caaddr m)))
(setcdr m (cdddr m))
(setq m (cdr m))))
marks))))
(defun gnus-article-fill-cited-article (&optional force)
"Do word wrapping in the current article."
(interactive (list t))
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
(marks (gnus-dissect-cited-text))
(adaptive-fill-mode nil))
(save-restriction
(while (cdr marks)
(widen)
(narrow-to-region (caar marks) (caadr marks))
(let ((adaptive-fill-regexp
(concat "^" (regexp-quote (cdar marks)) " *"))
(fill-prefix (cdar marks)))
(fill-region (point-min) (point-max)))
(set-marker (caar marks) nil)
(setq marks (cdr marks)))
(when marks
(set-marker (caar marks) nil))))))
(defun gnus-article-hide-citation (&optional arg force)
"Toggle hiding of all cited text except attribution lines.
See the documentation for `gnus-article-highlight-citation'.
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (append (gnus-hidden-arg) (list 'force)))
(setq gnus-cited-text-button-line-format-spec
(gnus-parse-format gnus-cited-text-button-line-format
gnus-cited-text-button-line-format-alist t))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(marks (gnus-dissect-cited-text))
(inhibit-point-motion-hooks t)
(props (nconc (list 'gnus-type 'cite)
gnus-hidden-properties))
beg end)
(while marks
(setq beg nil
end nil)
(while (and marks (string= (cdar marks) ""))
(setq marks (cdr marks)))
(when marks
(setq beg (caar marks)))
(while (and marks (not (string= (cdar marks) "")))
(setq marks (cdr marks)))
(when marks
(setq end (caar marks)))
;; Skip past lines we want to leave visible.
(when (and beg end gnus-cited-lines-visible)
(goto-char beg)
(forward-line gnus-cited-lines-visible)
(if (>= (point) end)
(setq beg nil)
(setq beg (point-marker))))
(when (and beg end)
(gnus-add-text-properties beg end props)
(goto-char beg)
(unless (save-excursion (search-backward "\n\n" nil t))
(insert "\n"))
(gnus-article-add-button
(point)
(progn (eval gnus-cited-text-button-line-format-spec) (point))
`gnus-article-toggle-cited-text (cons beg end))
(set-marker beg (point))))))))
(defun gnus-article-toggle-cited-text (region)
"Toggle hiding the text in REGION."
(let (buffer-read-only)
(funcall
(if (text-property-any
(car region) (1- (cdr region))
(car gnus-hidden-properties) (cadr gnus-hidden-properties))
'remove-text-properties 'gnus-add-text-properties)
(car region) (cdr region) gnus-hidden-properties)))
(defun gnus-article-hide-citation-maybe (&optional arg force)
"Toggle hiding of cited text that has an attribution line.
If given a negative prefix, always show; if given a positive prefix,
always hide.
This will do nothing unless at least `gnus-cite-hide-percentage'
percent and at least `gnus-cite-hide-absolute' lines of the body is
cited text with attributions. When called interactively, these two
variables are ignored.
See also the documentation for `gnus-article-highlight-citation'."
(interactive (append (gnus-hidden-arg) (list 'force)))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(let ((start (point))
(atts gnus-cite-attribution-alist)
(buffer-read-only nil)
(inhibit-point-motion-hooks t)
(hiden 0)
total)
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(setq total (count-lines start (point)))
(while atts
(setq hiden (+ hiden (length (cdr (assoc (cdar atts)
gnus-cite-prefix-alist))))
atts (cdr atts)))
(if (or force
(and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
(> hiden gnus-cite-hide-absolute)))
(progn
(setq atts gnus-cite-attribution-alist)
(while atts
(setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
atts (cdr atts))
(while total
(setq hiden (car total)
total (cdr total))
(goto-line hiden)
(or (assq hiden gnus-cite-attribution-alist)
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'gnus-type 'cite)
gnus-hidden-properties)))))))))))
(defun gnus-article-hide-citation-in-followups ()
"Hide cited text in non-root articles."
(interactive)
(save-excursion
(set-buffer gnus-article-buffer)
(let ((article (cdr gnus-article-current)))
(unless (save-excursion
(set-buffer gnus-summary-buffer)
(gnus-article-displayed-root-p article))
(gnus-article-hide-citation)))))
;;; Internal functions:
(defun gnus-cite-parse-maybe (&optional force)
;; Parse if the buffer has changes since last time.
(if (equal gnus-cite-article gnus-article-current)
()
;;Reset parser information.
(setq gnus-cite-prefix-alist nil
gnus-cite-attribution-alist nil
gnus-cite-loose-prefix-alist nil
gnus-cite-loose-attribution-alist nil)
;; Parse if not too large.
(if (and (not force)
gnus-cite-parse-max-size
(> (buffer-size) gnus-cite-parse-max-size))
()
(setq gnus-cite-article (cons (car gnus-article-current)
(cdr gnus-article-current)))
(gnus-cite-parse))))
(defun gnus-cite-parse ()
;; Parse and connect citation prefixes and attribution lines.
;; Parse current buffer searching for citation prefixes.
(goto-char (point-min))
(or (search-forward "\n\n" nil t)
(goto-char (point-max)))
(let ((line (1+ (count-lines (point-min) (point))))
(case-fold-search t)
(max (save-excursion
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(point)))
alist entry start begin end numbers prefix)
;; Get all potential prefixes in `alist'.
(while (< (point) max)
;; Each line.
(setq begin (point)
end (progn (beginning-of-line 2) (point))
start end)
(goto-char begin)
;; Ignore standard Supercite attribution prefix.
(if (looking-at gnus-supercite-regexp)
(if (match-end 1)
(setq end (1+ (match-end 1)))
(setq end (1+ begin))))
;; Ignore very long prefixes.
(if (> end (+ (point) gnus-cite-max-prefix))
(setq end (+ (point) gnus-cite-max-prefix)))
(while (re-search-forward gnus-cite-prefix-regexp (1- end) t)
;; Each prefix.
(setq end (match-end 0)
prefix (buffer-substring begin end))
(gnus-set-text-properties 0 (length prefix) nil prefix)
(setq entry (assoc prefix alist))
(if entry
(setcdr entry (cons line (cdr entry)))
(setq alist (cons (list prefix line) alist)))
(goto-char begin))
(goto-char start)
(setq line (1+ line)))
;; We got all the potential prefixes. Now create
;; `gnus-cite-prefix-alist' containing the oldest prefix for each
;; line that appears at least gnus-cite-minimum-match-count
;; times. First sort them by length. Longer is older.
(setq alist (sort alist (lambda (a b)
(> (length (car a)) (length (car b))))))
(while alist
(setq entry (car alist)
prefix (car entry)
numbers (cdr entry)
alist (cdr alist))
(cond ((null numbers)
;; No lines with this prefix that wasn't also part of
;; a longer prefix.
)
((< (length numbers) gnus-cite-minimum-match-count)
;; Too few lines with this prefix. We keep it a bit
;; longer in case it is an exact match for an attribution
;; line, but we don't remove the line from other
;; prefixes.
(setq gnus-cite-prefix-alist
(cons entry gnus-cite-prefix-alist)))
(t
(setq gnus-cite-prefix-alist (cons entry
gnus-cite-prefix-alist))
;; Remove articles from other prefixes.
(let ((loop alist)
current)
(while loop
(setq current (car loop)
loop (cdr loop))
(setcdr current
(gnus-set-difference (cdr current) numbers))))))))
;; No citations have been connected to attribution lines yet.
(setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil))
;; Parse current buffer searching for attribution lines.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
(let* ((start (match-beginning 0))
(end (match-end 0))
(wrote (count-lines (point-min) end))
(prefix (gnus-cite-find-prefix wrote))
;; Check previous line for an attribution leader.
(tag (progn
(beginning-of-line 1)
(and (looking-at gnus-supercite-secondary-regexp)
(buffer-substring (match-beginning 1)
(match-end 1)))))
(in (progn
(goto-char start)
(and (re-search-backward gnus-cite-attribution-prefix
(save-excursion
(beginning-of-line 0)
(point))
t)
(not (re-search-forward gnus-cite-attribution-suffix
start t))
(count-lines (point-min) (1+ (point)))))))
(if (eq wrote in)
(setq in nil))
(goto-char end)
(setq gnus-cite-loose-attribution-alist
(cons (list wrote in prefix tag)
gnus-cite-loose-attribution-alist))))
;; Find exact supercite citations.
(gnus-cite-match-attributions 'small nil
(lambda (prefix tag)
(if tag
(concat "\\`"
(regexp-quote prefix) "[ \t]*"
(regexp-quote tag) ">"))))
;; Find loose supercite citations after attributions.
(gnus-cite-match-attributions 'small t
(lambda (prefix tag)
(if tag (concat "\\<"
(regexp-quote tag)
"\\>"))))
;; Find loose supercite citations anywhere.
(gnus-cite-match-attributions 'small nil
(lambda (prefix tag)
(if tag (concat "\\<"
(regexp-quote tag)
"\\>"))))
;; Find nested citations after attributions.
(gnus-cite-match-attributions 'small-if-unique t
(lambda (prefix tag)
(concat "\\`" (regexp-quote prefix) ".+")))
;; Find nested citations anywhere.
(gnus-cite-match-attributions 'small nil
(lambda (prefix tag)
(concat "\\`" (regexp-quote prefix) ".+")))
;; Remove loose prefixes with too few lines.
(let ((alist gnus-cite-loose-prefix-alist)
entry)
(while alist
(setq entry (car alist)
alist (cdr alist))
(if (< (length (cdr entry)) gnus-cite-minimum-match-count)
(setq gnus-cite-prefix-alist
(delq entry gnus-cite-prefix-alist)
gnus-cite-loose-prefix-alist
(delq entry gnus-cite-loose-prefix-alist)))))
;; Find flat attributions.
(gnus-cite-match-attributions 'first t nil)
;; Find any attributions (are we getting desperate yet?).
(gnus-cite-match-attributions 'first nil nil))
(defun gnus-cite-match-attributions (sort after fun)
;; Match all loose attributions and citations (SORT AFTER FUN) .
;;
;; If SORT is `small', the citation with the shortest prefix will be
;; used, if it is `first' the first prefix will be used, if it is
;; `small-if-unique' the shortest prefix will be used if the
;; attribution line does not share its own prefix with other
;; loose attribution lines, otherwise the first prefix will be used.
;;
;; If AFTER is non-nil, only citations after the attribution line
;; will be considered.
;;
;; If FUN is non-nil, it will be called with the arguments (WROTE
;; PREFIX TAG) and expected to return a regular expression. Only
;; citations whose prefix matches the regular expression will be
;; considered.
;;
;; WROTE is the attribution line number.
;; PREFIX is the attribution line prefix.
;; TAG is the Supercite tag on the attribution line.
(let ((atts gnus-cite-loose-attribution-alist)
(case-fold-search t)
att wrote in prefix tag regexp limit smallest best size)
(while atts
(setq att (car atts)
atts (cdr atts)
wrote (nth 0 att)
in (nth 1 att)
prefix (nth 2 att)
tag (nth 3 att)
regexp (if fun (funcall fun prefix tag) "")
size (cond ((eq sort 'small) t)
((eq sort 'first) nil)
(t (< (length (gnus-cite-find-loose prefix)) 2)))
limit (if after wrote -1)
smallest 1000000
best nil)
(let ((cites gnus-cite-loose-prefix-alist)
cite candidate numbers first compare)
(while cites
(setq cite (car cites)
cites (cdr cites)
candidate (car cite)
numbers (cdr cite)
first (apply 'min numbers)
compare (if size (length candidate) first))
(and (> first limit)
regexp
(string-match regexp candidate)
(< compare smallest)
(setq best cite
smallest compare))))
(if (null best)
()
(setq gnus-cite-loose-attribution-alist
(delq att gnus-cite-loose-attribution-alist))
(setq gnus-cite-attribution-alist
(cons (cons wrote (car best)) gnus-cite-attribution-alist))
(if in
(setq gnus-cite-attribution-alist
(cons (cons in (car best)) gnus-cite-attribution-alist)))
(if (memq best gnus-cite-loose-prefix-alist)
(let ((loop gnus-cite-prefix-alist)
(numbers (cdr best))
current)
(setq gnus-cite-loose-prefix-alist
(delq best gnus-cite-loose-prefix-alist))
(while loop
(setq current (car loop)
loop (cdr loop))
(if (eq current best)
()
(setcdr current (gnus-set-difference (cdr current) numbers))
(if (null (cdr current))
(setq gnus-cite-loose-prefix-alist
(delq current gnus-cite-loose-prefix-alist)
atts (delq current atts)))))))))))
(defun gnus-cite-find-loose (prefix)
;; Return a list of loose attribution lines prefixed by PREFIX.
(let* ((atts gnus-cite-loose-attribution-alist)
att line lines)
(while atts
(setq att (car atts)
line (car att)
atts (cdr atts))
(if (string-equal (gnus-cite-find-prefix line) prefix)
(setq lines (cons line lines))))
lines))
(defun gnus-cite-add-face (number prefix face)
;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
(when face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(unless (eobp) ;; Sometimes things become confused.
(forward-char (length prefix))
(skip-chars-forward " \t")
(setq from (point))
(end-of-line 1)
(skip-chars-backward " \t")
(setq to (point))
(when (< from to)
(gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
(defun gnus-cite-toggle (prefix)
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
(inhibit-point-motion-hooks t)
number)
(while numbers
(setq number (car numbers)
numbers (cdr numbers))
(goto-line number)
(cond ((get-text-property (point) 'invisible)
(remove-text-properties (point) (progn (forward-line 1) (point))
gnus-hidden-properties))
((assq number gnus-cite-attribution-alist))
(t
(gnus-add-text-properties
(point) (progn (forward-line 1) (point))
(nconc (list 'gnus-type 'cite)
gnus-hidden-properties))))))))
(defun gnus-cite-find-prefix (line)
;; Return citation prefix for LINE.
(let ((alist gnus-cite-prefix-alist)
(prefix "")
entry)
(while alist
(setq entry (car alist)
alist (cdr alist))
(if (memq line (cdr entry))
(setq prefix (car entry))))
prefix))
(gnus-add-shutdown 'gnus-cache-close 'gnus)
(defun gnus-cache-close ()
(setq gnus-cite-prefix-alist nil))
(gnus-ems-redefine)
(provide 'gnus-cite)
;;; gnus-cite.el ends here

683
lisp/gnus-cus.el
View file

@ -1,683 +0,0 @@
;;; gnus-cus.el --- User friendly customization of Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: help, news
;; Version: 0.1
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'custom)
(require 'gnus-ems)
(require 'browse-url)
(eval-when-compile (require 'cl))
;; The following is just helper functions and data, not meant to be set
;; by the user.
(defun gnus-make-face (color)
;; Create entry for face with COLOR.
(custom-face-lookup color nil nil nil nil nil))
(defvar gnus-face-light-name-list
'("light blue" "light cyan" "light yellow" "light pink"
"pale green" "beige" "orange" "magenta" "violet" "medium purple"
"turquoise"))
(defvar gnus-face-dark-name-list
(list
;; Not all servers have dark blue in rgb.txt.
(if (and (eq window-system 'x) (x-color-defined-p "dark blue"))
"dark blue"
"royal blue")
"firebrick" "dark green" "OrangeRed"
"dark khaki" "dark violet" "SteelBlue4"))
; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3
; DarkOlviveGreen4
(custom-declare '()
'((tag . "Gnus")
(doc . "\
The coffee-brewing, all singing, all dancing, kitchen sink newsreader.")
(type . group)
(data
((tag . "Visual")
(doc . "\
Gnus can be made colorful and fun or grey and dull as you wish.")
(type . group)
(data
((tag . "Visual")
(doc . "Enable visual features.
If `visual' is disabled, there will be no menus and few faces. Most of
the visual customization options below will be ignored. Gnus will use
less space and be faster as a result.")
(default .
(summary-highlight group-highlight
article-highlight
mouse-face
summary-menu group-menu article-menu
tree-highlight menu highlight
browse-menu server-menu
page-marker tree-menu binary-menu pick-menu
grouplens-menu))
(name . gnus-visual)
(type . sexp))
((tag . "WWW Browser")
(doc . "\
WWW Browser to call when clicking on an URL button in the article buffer.
You can choose between one of the predefined browsers, or `Other'.")
(name . browse-url-browser-function)
(calculate . (cond ((boundp 'browse-url-browser-function)
browse-url-browser-function)
((fboundp 'w3-fetch)
'w3-fetch)
((eq window-system 'x)
'gnus-netscape-open-url)))
(type . choice)
(data
((tag . "W3")
(type . const)
(default . w3-fetch))
((tag . "Netscape")
(type . const)
(default . browse-url-netscape))
((prompt . "Other")
(doc . "\
You must specify the name of a Lisp function here. The lisp function
should open a WWW browser when called with an URL (a string).
")
(default . __uninitialized__)
(type . symbol))))
((tag . "Mouse Face")
(doc . "\
Face used for group or summary buffer mouse highlighting.
The line beneath the mouse pointer will be highlighted with this
face.")
(name . gnus-mouse-face)
(calculate . (condition-case ()
(if (gnus-visual-p 'mouse-face 'highlight)
(if (boundp 'gnus-mouse-face)
gnus-mouse-face
'highlight)
'default)
(error 'default)))
(type . face))
((tag . "Article Display")
(doc . "Controls how the article buffer will look.
If you leave the list empty, the article will appear exactly as it is
stored on the disk. The list entries will hide or highlight various
parts of the article, making it easier to find the information you
want.")
(name . gnus-article-display-hook)
(type . list)
(calculate
. (if (and (string-match "xemacs" emacs-version)
(featurep 'xface))
'(gnus-article-hide-headers-if-wanted
gnus-article-hide-boring-headers
gnus-article-treat-overstrike
gnus-article-maybe-highlight
gnus-article-display-x-face)
'(gnus-article-hide-headers-if-wanted
gnus-article-hide-boring-headers
gnus-article-treat-overstrike
gnus-article-maybe-highlight)))
(data
((type . repeat)
(header . nil)
(data
(tag . "Filter")
(type . choice)
(data
((tag . "Treat Overstrike")
(doc . "\
Convert use of overstrike into bold and underline.
Two identical letters separated by a backspace are displayed as a
single bold letter, while a letter followed by a backspace and an
underscore will be displayed as a single underlined letter. This
technique was developed for old line printers (think about it), and is
still in use on some newsgroups, in particular the ClariNet
hierarchy.
")
(type . const)
(default .
gnus-article-treat-overstrike))
((tag . "Word Wrap")
(doc . "\
Format too long lines.
")
(type . const)
(default . gnus-article-word-wrap))
((tag . "Remove CR")
(doc . "\
Remove carriage returns from an article.
")
(type . const)
(default . gnus-article-remove-cr))
((tag . "Display X-Face")
(doc . "\
Look for an X-Face header and display it if present.
See also `X Face Command' for a definition of the external command
used for decoding and displaying the face.
")
(type . const)
(default . gnus-article-display-x-face))
((tag . "Unquote Printable")
(doc . "\
Transform MIME quoted printable into 8-bit characters.
Quoted printable is often seen by strings like `=EF' where you would
expect a non-English letter.
")
(type . const)
(default .
gnus-article-de-quoted-unreadable))
((tag . "Universal Time")
(doc . "\
Convert date header to universal time.
")
(type . const)
(default . gnus-article-date-ut))
((tag . "Local Time")
(doc . "\
Convert date header to local timezone.
")
(type . const)
(default . gnus-article-date-local))
((tag . "Lapsed Time")
(doc . "\
Replace date header with a header showing the articles age.
")
(type . const)
(default . gnus-article-date-lapsed))
((tag . "Highlight")
(doc . "\
Highlight headers, citations, signature, and buttons.
")
(type . const)
(default . gnus-article-highlight))
((tag . "Maybe Highlight")
(doc . "\
Highlight headers, signature, and buttons if `Visual' is turned on.
")
(type . const)
(default .
gnus-article-maybe-highlight))
((tag . "Highlight Some")
(doc . "\
Highlight headers, signature, and buttons.
")
(type . const)
(default . gnus-article-highlight-some))
((tag . "Highlight Headers")
(doc . "\
Highlight headers as specified by `Article Header Highlighting'.
")
(type . const)
(default .
gnus-article-highlight-headers))
((tag . "Highlight Signature")
(doc . "\
Highlight the signature as specified by `Article Signature Face'.
")
(type . const)
(default .
gnus-article-highlight-signature))
((tag . "Citation")
(doc . "\
Highlight the citations as specified by `Citation Faces'.
")
(type . const)
(default .
gnus-article-highlight-citation))
((tag . "Hide")
(doc . "\
Hide unwanted headers, excess citation, and the signature.
")
(type . const)
(default . gnus-article-hide))
((tag . "Hide Headers If Wanted")
(doc . "\
Hide headers, but allow user to display them with `t' or `v'.
")
(type . const)
(default .
gnus-article-hide-headers-if-wanted))
((tag . "Hide Headers")
(doc . "\
Hide unwanted headers and possibly sort them as well.
Most likely you want to use `Hide Headers If Wanted' instead.
")
(type . const)
(default . gnus-article-hide-headers))
((tag . "Hide Signature")
(doc . "\
Hide the signature.
")
(type . const)
(default . gnus-article-hide-signature))
((tag . "Hide Excess Citations")
(doc . "\
Hide excess citation.
Excess is defined by `Citation Hide Percentage' and `Citation Hide Absolute'.
")
(type . const)
(default .
gnus-article-hide-citation-maybe))
((tag . "Hide Citations")
(doc . "\
Hide all cited text.
")
(type . const)
(default . gnus-article-hide-citation))
((tag . "Add Buttons")
(doc . "\
Make URL's into clickable buttons.
")
(type . const)
(default . gnus-article-add-buttons))
((prompt . "Other")
(doc . "\
Name of Lisp function to call.
Push the `Filter' button to select one of the predefined filters.
")
(type . symbol)))))))
((tag . "Article Button Face")
(doc . "\
Face used for highlighting buttons in the article buffer.
An article button is a piece of text that you can activate by pressing
`RET' or `mouse-2' above it.")
(name . gnus-article-button-face)
(default . bold)
(type . face))
((tag . "Article Mouse Face")
(doc . "\
Face used for mouse highlighting in the article buffer.
Article buttons will be displayed in this face when the cursor is
above them.")
(name . gnus-article-mouse-face)
(default . highlight)
(type . face))
((tag . "Article Signature Face")
(doc . "\
Face used for highlighting a signature in the article buffer.")
(name . gnus-signature-face)
(default . italic)
(type . face))
((tag . "Article Header Highlighting")
(doc . "\
Controls highlighting of article header.
Below is a list of article header names, and the faces used for
displaying the name and content of the header. The `Header' field
should contain the name of the header. The field actually contains a
regular expression that should match the beginning of the header line,
but if you don't know what a regular expression is, just write the
name of the header. The second field is the `Name' field, which
determines how the the header name (i.e. the part of the header left
of the `:') is displayed. The third field is the `Content' field,
which determines how the content (i.e. the part of the header right of
the `:') is displayed.
If you leave the last `Header' field in the list empty, the `Name' and
`Content' fields will determine how headers not listed above are
displayed.
If you only want to change the display of the name part for a specific
header, specify `None' in the `Content' field. Similarly, specify
`None' in the `Name' field if you only want to leave the name part
alone.")
(name . gnus-header-face-alist)
(type . list)
(calculate
. (cond
((not (eq gnus-display-type 'color))
'(("" bold italic)))
((eq gnus-background-mode 'dark)
(list
(list "From" nil
(custom-face-lookup "light blue" nil nil t t nil))
(list "Subject" nil
(custom-face-lookup "pink" nil nil t t nil))
(list "Newsgroups:.*," nil
(custom-face-lookup "yellow" nil nil t t nil))
(list
""
(custom-face-lookup "cyan" nil nil t nil nil)
(custom-face-lookup "forestgreen" nil nil nil t
nil))))
(t
(list
(list "From" nil
(custom-face-lookup "MidnightBlue" nil nil t t nil))
(list "Subject" nil
(custom-face-lookup "firebrick" nil nil t t nil))
(list "Newsgroups:.*," nil
(custom-face-lookup "indianred" nil nil t t nil))
(list ""
(custom-face-lookup
"DarkGreen" nil nil t nil nil)
(custom-face-lookup "DarkGreen" nil nil
nil t nil))))))
(data
((type . repeat)
(header . nil)
(data
(type . list)
(compact . t)
(data
((type . string)
(prompt . "Header")
(tag . "Header "))
"\n "
((type . face)
(prompt . "Name")
(tag . "Name "))
"\n "
((type . face)
(tag . "Content"))
"\n")))))
((tag . "Attribution Face")
(doc . "\
Face used for attribution lines.
It is merged with the face for the cited text belonging to the attribution.")
(name . gnus-cite-attribution-face)
(default . underline)
(type . face))
((tag . "Citation Faces")
(doc . "\
List of faces used for highlighting citations.
When there are citations from multiple articles in the same message,
Gnus will try to give each citation from each article its own face.
This should make it easier to see who wrote what.")
(name . gnus-cite-face-list)
(import . gnus-custom-import-cite-face-list)
(type . list)
(calculate . (cond ((not (eq gnus-display-type 'color))
'(italic))
((eq gnus-background-mode 'dark)
(mapcar 'gnus-make-face
gnus-face-light-name-list))
(t
(mapcar 'gnus-make-face
gnus-face-dark-name-list))))
(data
((type . repeat)
(header . nil)
(data (type . face)
(tag . "Face")))))
((tag . "Citation Hide Percentage")
(doc . "\
Only hide excess citation if above this percentage of the body.")
(name . gnus-cite-hide-percentage)
(default . 50)
(type . integer))
((tag . "Citation Hide Absolute")
(doc . "\
Only hide excess citation if above this number of lines in the body.")
(name . gnus-cite-hide-absolute)
(default . 10)
(type . integer))
((tag . "Summary Selected Face")
(doc . "\
Face used for highlighting the current article in the summary buffer.")
(name . gnus-summary-selected-face)
(default . underline)
(type . face))
((tag . "Summary Line Highlighting")
(doc . "\
Controls the highlighting of summary buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
particular summary line should be displayed, each form is
evaluated. The content of the face field after the first true form is
used. You can change how those summary lines are displayed, by
editing the face field.
It is also possible to change and add form fields, but currently that
requires an understanding of Lisp expressions. Hopefully this will
change in a future release. For now, you can use the following
variables in the Lisp expression:
score: The article's score
default: The default article score.
below: The score below which articles are automatically marked as read.
mark: The article's mark.")
(name . gnus-summary-highlight)
(type . list)
(calculate
. (cond
((not (eq gnus-display-type 'color))
'(((> score default) . bold)
((< score default) . italic)))
((eq gnus-background-mode 'dark)
(list
(cons
'(= mark gnus-canceled-mark)
(custom-face-lookup "yellow" "black" nil
nil nil nil))
(cons '(and (> score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup
"pink" nil nil t nil nil))
(cons '(and (< score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "pink" nil nil
nil t nil))
(cons '(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark))
(custom-face-lookup
"pink" nil nil nil nil nil))
(cons
'(and (> score default) (= mark gnus-ancient-mark))
(custom-face-lookup "medium blue" nil nil t
nil nil))
(cons
'(and (< score default) (= mark gnus-ancient-mark))
(custom-face-lookup "SkyBlue" nil nil
nil t nil))
(cons
'(= mark gnus-ancient-mark)
(custom-face-lookup "SkyBlue" nil nil
nil nil nil))
(cons '(and (> score default) (= mark gnus-unread-mark))
(custom-face-lookup "white" nil nil t
nil nil))
(cons '(and (< score default) (= mark gnus-unread-mark))
(custom-face-lookup "white" nil nil
nil t nil))
(cons '(= mark gnus-unread-mark)
(custom-face-lookup
"white" nil nil nil nil nil))
(cons '(> score default) 'bold)
(cons '(< score default) 'italic)))
(t
(list
(cons
'(= mark gnus-canceled-mark)
(custom-face-lookup
"yellow" "black" nil nil nil nil))
(cons '(and (> score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "firebrick" nil nil
t nil nil))
(cons '(and (< score default)
(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark)))
(custom-face-lookup "firebrick" nil nil
nil t nil))
(cons
'(or (= mark gnus-dormant-mark)
(= mark gnus-ticked-mark))
(custom-face-lookup
"firebrick" nil nil nil nil nil))
(cons '(and (> score default) (= mark gnus-ancient-mark))
(custom-face-lookup "RoyalBlue" nil nil
t nil nil))
(cons '(and (< score default) (= mark gnus-ancient-mark))
(custom-face-lookup "RoyalBlue" nil nil
nil t nil))
(cons
'(= mark gnus-ancient-mark)
(custom-face-lookup
"RoyalBlue" nil nil nil nil nil))
(cons '(and (> score default) (/= mark gnus-unread-mark))
(custom-face-lookup "DarkGreen" nil nil
t nil nil))
(cons '(and (< score default) (/= mark gnus-unread-mark))
(custom-face-lookup "DarkGreen" nil nil
nil t nil))
(cons
'(/= mark gnus-unread-mark)
(custom-face-lookup "DarkGreen" nil nil
nil nil nil))
(cons '(> score default) 'bold)
(cons '(< score default) 'italic)))))
(data
((type . repeat)
(header . nil)
(data (type . pair)
(compact . t)
(data ((type . sexp)
(width . 60)
(tag . "Form"))
"\n "
((type . face)
(tag . "Face"))
"\n")))))
((tag . "Group Line Highlighting")
(doc . "\
Controls the highlighting of group buffer lines.
Below is a list of `Form'/`Face' pairs. When deciding how a a
particular group line should be displayed, each form is
evaluated. The content of the face field after the first true form is
used. You can change how those group lines are displayed by
editing the face field.
It is also possible to change and add form fields, but currently that
requires an understanding of Lisp expressions. Hopefully this will
change in a future release. For now, you can use the following
variables in the Lisp expression:
group: The name of the group.
unread: The number of unread articles in the group.
method: The select method used.
mailp: Whether it's a mail group or not.
level: The level of the group.
score: The score of the group.
ticked: The number of ticked articles.")
(name . gnus-group-highlight)
(type . list)
(calculate
. (cond
((not (eq gnus-display-type 'color))
'((mailp . bold)
((= unread 0) . italic)))
((eq gnus-background-mode 'dark)
`(((and (not mailp) (eq level 1)) .
,(custom-face-lookup "PaleTurquoise" nil nil t))
((and (not mailp) (eq level 2)) .
,(custom-face-lookup "turquoise" nil nil t))
((and (not mailp) (eq level 3)) .
,(custom-face-lookup "MediumTurquoise" nil nil t))
((and (not mailp) (>= level 4)) .
,(custom-face-lookup "DarkTurquoise" nil nil t))
((and mailp (eq level 1)) .
,(custom-face-lookup "aquamarine1" nil nil t))
((and mailp (eq level 2)) .
,(custom-face-lookup "aquamarine2" nil nil t))
((and mailp (eq level 3)) .
,(custom-face-lookup "aquamarine3" nil nil t))
((and mailp (>= level 4)) .
,(custom-face-lookup "aquamarine4" nil nil t))
))
(t
`(((and (not mailp) (<= level 3)) .
,(custom-face-lookup "ForestGreen" nil nil t))
((and (not mailp) (eq level 4)) .
,(custom-face-lookup "DarkGreen" nil nil t))
((and (not mailp) (eq level 5)) .
,(custom-face-lookup "CadetBlue4" nil nil t))
((and mailp (eq level 1)) .
,(custom-face-lookup "DeepPink3" nil nil t))
((and mailp (eq level 2)) .
,(custom-face-lookup "HotPink3" nil nil t))
((and mailp (eq level 3)) .
,(custom-face-lookup
;; Not all servers have dark magenta in rgb.txt.
(if (and (eq window-system 'x)
(x-color-defined-p "dark magenta"))
"dark magenta"
"maroon")
nil nil t))
((and mailp (eq level 4)) .
,(custom-face-lookup "DeepPink4" nil nil t))
((and mailp (> level 4)) .
,(custom-face-lookup "DarkOrchid4" nil nil t))
))))
(data
((type . repeat)
(header . nil)
(data (type . pair)
(compact . t)
(data ((type . sexp)
(width . 60)
(tag . "Form"))
"\n "
((type . face)
(tag . "Face"))
"\n")))))
;; Do not define `gnus-button-alist' before we have
;; some `complexity' attribute so we can hide it from
;; beginners.
)))))
(defun gnus-custom-import-cite-face-list (custom alist)
;; Backward compatible grokking of light and dark.
(cond ((eq alist 'light)
(setq alist (mapcar 'gnus-make-face gnus-face-light-name-list)))
((eq alist 'dark)
(setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list))))
(funcall (custom-super custom 'import) custom alist))
(provide 'gnus-cus)
;;; gnus-cus.el ends here

222
lisp/gnus-demon.el
View file

@ -1,222 +0,0 @@
;;; gnus-demon.el --- daemonic Gnus behaviour
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-demon-handlers nil
"Alist of daemonic handlers to be run at intervals.
Each handler is a list on the form
\(FUNCTION TIME IDLE)
FUNCTION is the function to be called.
TIME is the number of `gnus-demon-timestep's between each call.
If nil, never call. If t, call each `gnus-demon-timestep'.
If IDLE is t, only call if Emacs has been idle for a while. If IDLE
is a number, only call when Emacs has been idle more than this number
of `gnus-demon-timestep's. If IDLE is nil, don't care about
idleness. If IDLE is a number and TIME is nil, then call once each
time Emacs has been idle for IDLE `gnus-demon-timestep's.")
(defvar gnus-demon-timestep 60
"*Number of seconds in each demon timestep.")
;;; Internal variables.
(defvar gnus-demon-timer nil)
(defvar gnus-demon-idle-has-been-called nil)
(defvar gnus-demon-idle-time 0)
(defvar gnus-demon-handler-state nil)
(defvar gnus-demon-is-idle nil)
(defvar gnus-demon-last-keys nil)
(eval-and-compile
(autoload 'timezone-parse-date "timezone")
(autoload 'timezone-make-arpa-date "timezone"))
;;; Functions.
(defun gnus-demon-add-handler (function time idle)
"Add the handler FUNCTION to be run at TIME and IDLE."
;; First remove any old handlers that use this function.
(gnus-demon-remove-handler function)
;; Then add the new one.
(push (list function time idle) gnus-demon-handlers)
(gnus-demon-init))
(defun gnus-demon-remove-handler (function &optional no-init)
"Remove the handler FUNCTION from the list of handlers."
(setq gnus-demon-handlers
(delq (assq function gnus-demon-handlers)
gnus-demon-handlers))
(or no-init (gnus-demon-init)))
(defun gnus-demon-init ()
"Initialize the Gnus daemon."
(interactive)
(gnus-demon-cancel)
(if (null gnus-demon-handlers)
() ; Nothing to do.
;; Set up timer.
(setq gnus-demon-timer
(nnheader-run-at-time
gnus-demon-timestep gnus-demon-timestep 'gnus-demon))
;; Reset control variables.
(setq gnus-demon-handler-state
(mapcar
(lambda (handler)
(list (car handler) (gnus-demon-time-to-step (nth 1 handler))
(nth 2 handler)))
gnus-demon-handlers))
(setq gnus-demon-idle-time 0)
(setq gnus-demon-idle-has-been-called nil)
(setq gnus-use-demon t)))
(gnus-add-shutdown 'gnus-demon-cancel 'gnus)
(defun gnus-demon-cancel ()
"Cancel any Gnus daemons."
(interactive)
(and gnus-demon-timer
(nnheader-cancel-timer gnus-demon-timer))
(setq gnus-demon-timer nil
gnus-use-demon nil))
(defun gnus-demon-is-idle-p ()
"Whether Emacs is idle or not."
;; We do this simply by comparing the 100 most recent keystrokes
;; with the ones we had last time. If they are the same, one might
;; guess that Emacs is indeed idle. This only makes sense if one
;; calls this function seldom -- like once a minute, which is what
;; we do here.
(let ((keys (recent-keys)))
(or (equal keys gnus-demon-last-keys)
(progn
(setq gnus-demon-last-keys keys)
nil))))
(defun gnus-demon-time-to-step (time)
"Find out how many seconds to TIME, which is on the form \"17:43\"."
(if (not (stringp time))
time
(let* ((date (current-time-string))
(dv (timezone-parse-date date))
(tdate (timezone-make-arpa-date
(string-to-number (aref dv 0))
(string-to-number (aref dv 1))
(string-to-number (aref dv 2)) time
(or (aref dv 4) "UT")))
(nseconds (gnus-time-minus
(gnus-encode-date tdate) (gnus-encode-date date))))
(round
(/ (if (< nseconds 0)
(+ nseconds (* 60 60 24))
nseconds) gnus-demon-timestep)))))
(defun gnus-demon ()
"The Gnus daemon that takes care of running all Gnus handlers."
;; Increase or reset the time Emacs has been idle.
(if (gnus-demon-is-idle-p)
(incf gnus-demon-idle-time)
(setq gnus-demon-idle-time 0)
(setq gnus-demon-idle-has-been-called nil))
;; Then we go through all the handler and call those that are
;; sufficiently ripe.
(let ((handlers gnus-demon-handler-state)
handler time idle)
(while handlers
(setq handler (pop handlers))
(cond
((numberp (setq time (nth 1 handler)))
;; These handlers use a regular timeout mechanism. We decrease
;; the timer if it hasn't reached zero yet.
(or (zerop time)
(setcar (nthcdr 1 handler) (decf time)))
(and (zerop time) ; If the timer now is zero...
(or (not (setq idle (nth 2 handler))) ; Don't care about idle.
(and (numberp idle) ; Numerical idle...
(< idle gnus-demon-idle-time)) ; Idle timed out.
gnus-demon-is-idle) ; Or just need to be idle.
;; So we call the handler.
(progn
(funcall (car handler))
;; And reset the timer.
(setcar (nthcdr 1 handler)
(gnus-demon-time-to-step
(nth 1 (assq (car handler) gnus-demon-handlers)))))))
;; These are only supposed to be called when Emacs is idle.
((null (setq idle (nth 2 handler)))
;; We do nothing.
)
((not (numberp idle))
;; We want to call this handler each and every time that
;; Emacs is idle.
(funcall (car handler)))
(t
;; We want to call this handler only if Emacs has been idle
;; for a specified number of timesteps.
(and (not (memq (car handler) gnus-demon-idle-has-been-called))
(< idle gnus-demon-idle-time)
(progn
(funcall (car handler))
;; Make sure the handler won't be called once more in
;; this idle-cycle.
(push (car handler) gnus-demon-idle-has-been-called))))))))
(defun gnus-demon-add-nocem ()
"Add daemonic NoCeM handling to Gnus."
(gnus-demon-add-handler 'gnus-demon-scan-nocem 60 t))
(defun gnus-demon-scan-nocem ()
"Scan NoCeM groups for NoCeM messages."
(gnus-nocem-scan-groups))
(defun gnus-demon-add-disconnection ()
"Add daemonic server disconnection to Gnus."
(gnus-demon-add-handler 'gnus-demon-close-connections nil 30))
(defun gnus-demon-close-connections ()
(gnus-close-backends))
(defun gnus-demon-add-scanmail ()
"Add daemonic scanning of mail from the mail backends."
(gnus-demon-add-handler 'gnus-demon-scan-mail 120 60))
(defun gnus-demon-scan-mail ()
(let ((servers gnus-opened-servers)
server)
(while (setq server (car (pop servers)))
(and (gnus-check-backend-function 'request-scan (car server))
(or (gnus-server-opened server)
(gnus-open-server server))
(gnus-request-scan nil server)))))
(provide 'gnus-demon)
;;; gnus-demon.el ends here

630
lisp/gnus-edit.el
View file

@ -1,630 +0,0 @@
;;; gnus-edit.el --- Gnus SCORE file editing
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: news, help
;; Version: 0.2
;;; Commentary:
;;
;; Type `M-x gnus-score-customize RET' to invoke.
;;; Code:
(require 'custom)
(require 'gnus-score)
(eval-when-compile (require 'cl))
(defconst gnus-score-custom-data
'((tag . "Score")
(doc . "Customization of Gnus SCORE files.
SCORE files allow you to assign a score to each article when you enter
a group, and automatically mark the articles as read or delete them
based on the score. In the summary buffer you can use the score to
sort the articles by score (`C-c C-s C-s') or to jump to the unread
article with the highest score (`,').")
(type . group)
(data "\n"
((header . nil)
(doc . "Name of SCORE file to customize.
Enter the name in the `File' field, then push the [Load] button to
load it. When done editing, push the [Save] button to save the file.
Several score files may apply to each group, and several groups may
use the same score file. This is controlled implicitly by the name of
the score file and the value of the global variable
`gnus-score-find-score-files-function', and explicitly by the the
`Files' and `Exclude Files' entries.")
(compact . t)
(type . group)
(data ((tag . "Load")
(type . button)
(query . gnus-score-custom-load))
((tag . "Save")
(type . button)
(query . gnus-score-custom-save))
((name . file)
(tag . "File")
(directory . gnus-kill-files-directory)
(default-file . "SCORE")
(type . file))))
((name . files)
(tag . "Files")
(doc . "\
List of score files to load when the the current score file is loaded.
You can use this to share score entries between multiple score files.
Push the `[INS]' button add a score file to the list, or `[DEL]' to
delete a score file from the list.")
(type . list)
(data ((type . repeat)
(header . nil)
(data (type . file)
(directory . gnus-kill-files-directory)))))
((name . exclude-files)
(tag . "Exclude Files")
(doc . "\
List of score files to exclude when the the current score file is loaded.
You can use this if you have a score file you want to share between a
number of newsgroups, except for the newsgroup this score file
matches. [ Did anyone get that? ]
Push the `[INS]' button add a score file to the list, or `[DEL]' to
delete a score file from the list.")
(type . list)
(data ((type . repeat)
(header . nil)
(data (type . file)
(directory . gnus-kill-files-directory)))))
((name . mark)
(tag . "Mark")
(doc . "\
Articles below this score will be automatically marked as read.
This means that when you enter the summary buffer, the articles will
be shown but will already be marked as read. You can then press `x'
to get rid of them entirely.
By default articles with a negative score will be marked as read. To
change this, push the `Mark' button, and choose `Integer'. You can
then enter a value in the `Mark' field.")
(type . gnus-score-custom-maybe-type))
((name . expunge)
(tag . "Expunge")
(doc . "\
Articles below this score will not be shown in the summary buffer.")
(type . gnus-score-custom-maybe-type))
((name . mark-and-expunge)
(tag . "Mark and Expunge")
(doc . "\
Articles below this score will be marked as read, but not shown.
Someone should explain me the difference between this and `expunge'
alone or combined with `mark'.")
(type . gnus-score-custom-maybe-type))
((name . eval)
(tag . "Eval")
(doc . "\
Evaluate this lisp expression when the entering summary buffer.")
(type . sexp))
((name . read-only)
(tag . "Read Only")
(doc . "Read-only score files will not be updated or saved.
Except from this buffer, of course!")
(type . toggle))
((type . doc)
(doc . "\
Each news header has an associated list of score entries.
You can use the [INS] buttons to add new score entries anywhere in the
list, or the [DEL] buttons to delete specific score entries.
Each score entry should specify a string that should be matched with
the content actual header in order to determine whether the entry
applies to that header. Enter that string in the `Match' field.
If the score entry matches, the articles score will be adjusted with
some amount. Enter that amount in the in the `Score' field. You
should specify a positive amount for score entries that matches
articles you find interesting, and a negative amount for score entries
matching articles you would rather avoid. The final score for the
article will be the sum of the score of all score entries that match
the article.
The score entry can be either permanent or expirable. To make the
entry permanent, push the `Date' button and choose the `Permanent'
entry. To make the entry expirable, choose instead the `Integer'
entry. After choosing the you can enter the date the score entry was
last matched in the `Date' field. The date will be automatically
updated each time the score entry matches an article. When the date
become too old, the the score entry will be removed.
For your convenience, the date is specified as the number of days
elapsed since the (imaginary) Gregorian date Sunday, December 31, 1
BC.
Finally, you can choose what kind of match you want to perform by
pushing the `Type' button. For most entries you can choose between
`Exact' which mean the header content must be exactly identical to the
match string, or `Substring' meaning the match string should be
somewhere in the header content, or even `Regexp' to use Emacs regular
expression matching. The last choice is `Fuzzy' which is like `Exact'
except that whitespace derivations, a beginning `Re:' or a terminating
parenthetical remark are all ignored. Each of the four types have a
variant which will ignore case in the comparison. That variant is
indicated with a `(fold)' after its name."))
((name . from)
(tag . "From")
(doc . "Scoring based on the authors email address.")
(type . gnus-score-custom-string-type))
((name . subject)
(tag . "Subject")
(doc . "Scoring based on the articles subject.")
(type . gnus-score-custom-string-type))
((name . followup)
(tag . "Followup")
(doc . "Scoring based on who the article is a followup to.
If you want to see all followups to your own articles, add an entry
with a positive score matching your email address here. You can also
put an entry with a negative score matching someone who is so annoying
that you don't even want to see him quoted in followups.")
(type . gnus-score-custom-string-type))
((name . xref)
(tag . "Xref")
(doc . "Scoring based on article crossposting.
If you want to score based on which newsgroups an article is posted
to, this is the header to use. The syntax is a little different from
the `Newsgroups' header, but scoring in `Xref' is much faster. As an
example, to match all crossposted articles match on `:.*:' using the
`Regexp' type.")
(type . gnus-score-custom-string-type))
((name . references)
(tag . "References")
(doc . "Scoring based on article references.
The `References' header gives you an alternative way to score on
followups. If you for example want to see follow all discussions
where people from `iesd.auc.dk' school participate, you can add a
substring match on `iesd.auc.dk>' on this header.")
(type . gnus-score-custom-string-type))
((name . message-id)
(tag . "Message-ID")
(doc . "Scoring based on the articles message-id.
This isn't very useful, but Lars like completeness. You can use it to
match all messaged generated by recent Gnus version with a `Substring'
match on `.fsf@'.")
(type . gnus-score-custom-string-type))
((type . doc)
(doc . "\
WARNING: Scoring on the following three pseudo headers is very slow!
Scoring on any of the real headers use a technique that avoids
scanning the entire article, only the actual headers you score on are
scanned, and this scanning has been heavily optimized. Using just a
single entry for one the three pseudo-headers `Head', `Body', and
`All' will require GNUS to retrieve and scan the entire article, which
can be very slow on large groups. However, if you add one entry for
any of these headers, you can just as well add several. Each
subsequent entry cost relatively little extra time."))
((name . head)
(tag . "Head")
(doc . "Scoring based on the article header.
Instead of matching the content of a single header, the entire header
section of the article is matched. You can use this to match on
arbitrary headers, foe example to single out TIN lusers, use a substring
match on `Newsreader: TIN'. That should get 'em!")
(type . gnus-score-custom-string-type))
((name . body)
(tag . "Body")
(doc . "Scoring based on the article body.
If you think any article that mentions `Kibo' is inherently
interesting, do a substring match on His name. You Are Allowed.")
(type . gnus-score-custom-string-type))
((name . all)
(tag . "All")
(doc . "Scoring based on the whole article.")
(type . gnus-score-custom-string-type))
((name . date)
(tag . "Date")
(doc . "Scoring based on article date.
You can change the score of articles that have been posted before,
after, or at a specific date. You should add the date in the `Match'
field, and then select `before', `after', or `at' by pushing the
`Type' button. Imagine you want to lower the score of very old
articles, or want to raise the score of articles from the future (such
things happen!). Then you can't use date scoring for that. In fact,
I can't imagine anything you would want to use this for.
For your convenience, the date is specified in Usenet date format.")
(type . gnus-score-custom-date-type))
((type . doc)
(doc . "\
The Lines and Chars headers use integer based scoring.
This means that you should write an integer in the `Match' field, and
the push the `Type' field to if the `Chars' or `Lines' header should
be larger, equal, or smaller than the number you wrote in the match
field."))
((name . chars)
(tag . "Characters")
(doc . "Scoring based on the number of characters in the article.")
(type . gnus-score-custom-integer-type))
((name . lines)
(tag . "Lines")
(doc . "Scoring based on the number of lines in the article.")
(type . gnus-score-custom-integer-type))
((name . orphan)
(tag . "Orphan")
(doc . "Score to add to articles with no parents.")
(type . gnus-score-custom-maybe-type))
((name . adapt)
(tag . "Adapt")
(doc . "Adapting the score files to your newsreading habits.
When you have finished reading a group GNUS can automatically create
new score entries based on which articles you read and which you
skipped. This is normally controlled by the two global variables
`gnus-use-adaptive-scoring' and `gnus-default-adaptive-score-alist',
The first determines whether adaptive scoring should be enabled or
not, while the second determines what score entries should be created.
You can overwrite the setting of `gnus-use-adaptive-scoring' by
selecting `Enable' or `Disable' by pressing the `Adapt' button.
Selecting `Custom' will allow you to specify the exact adaptation
rules (overwriting `gnus-default-adaptive-score-alist').")
(type . choice)
(data ((tag . "Default")
(default . nil)
(type . const))
((tag . "Enable")
(default . t)
(type . const))
((tag . "Disable")
(default . ignore)
(type . const))
((tag . "Custom")
(doc . "Customization of adaptive scoring.
Each time you read an article it will be marked as read. Likewise, if
you delete it it will be marked as deleted, and if you tick it it will
be marked as ticked. When you leave a group, GNUS can automatically
create score file entries based on these marks, so next time you enter
the group articles with subjects that you read last time have higher
score and articles with subjects that deleted will have lower score.
Below is a list of such marks. You can insert new marks to the list
by pushing on one of the `[INS]' buttons in the left margin to create
a new entry and then pushing the `Mark' button to select the mark.
For each mark there is another list, this time of article headers,
which determine how the mark should affect that header. The `[INS]'
buttons of this list are indented to indicate that the belong to the
mark above. Push the `Header' button to choose a header, and then
enter a score value in the `Score' field.
For each article that are marked with `Mark' when you leave the
group, a temporary score entry for the articles `Header' with the
value of `Score' will be added the adapt file. If the score entry
already exists, `Score' will be added to its value. If you understood
that, you are smart.
You can select the special value `Other' when pressing the `Mark' or
`Header' buttons. This is because Lars might add more useful values
there. If he does, it is up to you to figure out what they are named.")
(type . list)
(default . ((__uninitialized__)))
(data ((type . repeat)
(header . nil)
(data . ((type . list)
(header . nil)
(compact . t)
(data ((type . choice)
(tag . "Mark")
(data ((tag . "Unread")
(default . gnus-unread-mark)
(type . const))
((tag . "Ticked")
(default . gnus-ticked-mark)
(type . const))
((tag . "Dormant")
(default . gnus-dormant-mark)
(type . const))
((tag . "Deleted")
(default . gnus-del-mark)
(type . const))
((tag . "Read")
(default . gnus-read-mark)
(type . const))
((tag . "Expirable")
(default . gnus-expirable-mark)
(type . const))
((tag . "Killed")
(default . gnus-killed-mark)
(type . const))
((tag . "Kill-file")
(default . gnus-kill-file-mark)
(type . const))
((tag . "Low-score")
(default . gnus-low-score-mark)
(type . const))
((tag . "Catchup")
(default . gnus-catchup-mark)
(type . const))
((tag . "Ancient")
(default . gnus-ancient-mark)
(type . const))
((tag . "Canceled")
(default . gnus-canceled-mark)
(type . const))
((prompt . "Other")
(default . ??)
(type . sexp))))
((type . repeat)
(prefix . " ")
(data . ((type . list)
(compact . t)
(data ((tag . "Header")
(type . choice)
(data ((tag . "Subject")
(default . subject)
(type . const))
((prompt . "From")
(tag . "From ")
(default . from)
(type . const))
((prompt . "Other")
(width . 7)
(default . nil)
(type . symbol))))
((tag . "Score")
(type . integer))))))))))))))
((name . local)
(tag . "Local")
(doc . "\
List of local variables to set when this score file is loaded.
Using this entry can provide a convenient way to set variables that
will affect the summary mode for only some specific groups, i.e. those
groups matched by the current score file.")
(type . list)
(data ((type . repeat)
(header . nil)
(data . ((type . list)
(compact . t)
(data ((tag . "Name")
(width . 26)
(type . symbol))
((tag . "Value")
(width . 26)
(type . sexp)))))))))))
(defconst gnus-score-custom-type-properties
'((gnus-score-custom-maybe-type
(type . choice)
(data ((type . integer)
(default . 0))
((tag . "Default")
(type . const)
(default . nil))))
(gnus-score-custom-string-type
(type . list)
(data ((type . repeat)
(header . nil)
(data . ((type . list)
(compact . t)
(data ((tag . "Match")
(width . 59)
(type . string))
"\n "
((tag . "Score")
(type . integer))
((tag . "Date")
(type . choice)
(data ((type . integer)
(default . 0)
(width . 9))
((tag . "Permanent")
(type . const)
(default . nil))))
((tag . "Type")
(type . choice)
(data ((tag . "Exact")
(default . E)
(type . const))
((tag . "Substring")
(default . S)
(type . const))
((tag . "Regexp")
(default . R)
(type . const))
((tag . "Fuzzy")
(default . F)
(type . const))
((tag . "Exact (fold)")
(default . e)
(type . const))
((tag . "Substring (fold)")
(default . s)
(type . const))
((tag . "Regexp (fold)")
(default . r)
(type . const))
((tag . "Fuzzy (fold)")
(default . f)
(type . const))))))))))
(gnus-score-custom-integer-type
(type . list)
(data ((type . repeat)
(header . nil)
(data . ((type . list)
(compact . t)
(data ((tag . "Match")
(type . integer))
((tag . "Score")
(type . integer))
((tag . "Date")
(type . choice)
(data ((type . integer)
(default . 0)
(width . 9))
((tag . "Permanent")
(type . const)
(default . nil))))
((tag . "Type")
(type . choice)
(data ((tag . "<")
(default . <)
(type . const))
((tag . ">")
(default . >)
(type . const))
((tag . "=")
(default . =)
(type . const))
((tag . ">=")
(default . >=)
(type . const))
((tag . "<=")
(default . <=)
(type . const))))))))))
(gnus-score-custom-date-type
(type . list)
(data ((type . repeat)
(header . nil)
(data . ((type . list)
(compact . t)
(data ((tag . "Match")
(width . 59)
(type . string))
"\n "
((tag . "Score")
(type . integer))
((tag . "Date")
(type . choice)
(data ((type . integer)
(default . 0)
(width . 9))
((tag . "Permanent")
(type . const)
(default . nil))))
((tag . "Type")
(type . choice)
(data ((tag . "Before")
(default . before)
(type . const))
((tag . "After")
(default . after)
(type . const))
((tag . "At")
(default . at)
(type . const))))))))))))
(defvar gnus-score-custom-file nil
"Name of SCORE file being customized.")
(defun gnus-score-customize ()
"Create a buffer for editing gnus SCORE files."
(interactive)
(let (gnus-score-alist)
(custom-buffer-create "*Score Edit*" gnus-score-custom-data
gnus-score-custom-type-properties
'gnus-score-custom-set
'gnus-score-custom-get
'gnus-score-custom-save))
(make-local-variable 'gnus-score-custom-file)
(setq gnus-score-custom-file
(expand-file-name "SCORE" gnus-kill-files-directory))
(make-local-variable 'gnus-score-alist)
(setq gnus-score-alist nil)
(custom-reset-all))
(defun gnus-score-custom-get (name)
(if (eq name 'file)
gnus-score-custom-file
(let ((entry (assoc (symbol-name name) gnus-score-alist)))
(if entry
(mapcar 'gnus-score-custom-sanify (cdr entry))
(setq entry (assoc name gnus-score-alist))
(if (or (memq name '(files exclude-files local))
(and (eq name 'adapt)
(not (symbolp (car (cdr entry))))))
(cdr entry)
(car (cdr entry)))))))
(defun gnus-score-custom-set (name value)
(cond ((eq name 'file)
(setq gnus-score-custom-file value))
((assoc (symbol-name name) gnus-score-alist)
(if value
(setcdr (assoc (symbol-name name) gnus-score-alist) value)
(setq gnus-score-alist (delq (assoc (symbol-name name)
gnus-score-alist)
gnus-score-alist))))
((assoc (symbol-name name) gnus-header-index)
(if value
(setq gnus-score-alist
(cons (cons (symbol-name name) value) gnus-score-alist))))
((assoc name gnus-score-alist)
(cond ((null value)
(setq gnus-score-alist (delq (assoc name gnus-score-alist)
gnus-score-alist)))
((and (listp value) (not (eq name 'eval)))
(setcdr (assoc name gnus-score-alist) value))
(t
(setcdr (assoc name gnus-score-alist) (list value)))))
((null value))
((and (listp value) (not (eq name 'eval)))
(setq gnus-score-alist (cons (cons name value) gnus-score-alist)))
(t
(setq gnus-score-alist
(cons (cons name (list value)) gnus-score-alist)))))
(defun gnus-score-custom-sanify (entry)
(list (nth 0 entry)
(or (nth 1 entry) gnus-score-interactive-default-score)
(nth 2 entry)
(cond ((null (nth 3 entry))
's)
((memq (nth 3 entry) '(before after at >= <=))
(nth 3 entry))
(t
(intern (substring (symbol-name (nth 3 entry)) 0 1))))))
(defvar gnus-score-cache nil)
(defun gnus-score-custom-load ()
(interactive)
(let ((file (custom-name-value 'file)))
(if (eq file custom-nil)
(error "You must specify a file name"))
(setq file (expand-file-name file gnus-kill-files-directory))
(gnus-score-load file)
(setq gnus-score-custom-file file)
(custom-reset-all)
(gnus-message 4 "Loaded")))
(defun gnus-score-custom-save ()
(interactive)
(custom-apply-all)
(gnus-score-remove-from-cache gnus-score-custom-file)
(let ((file gnus-score-custom-file)
(score gnus-score-alist)
emacs-lisp-mode-hook)
(save-excursion
(set-buffer (get-buffer-create "*Score*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(pp score (current-buffer))
(gnus-make-directory (file-name-directory file))
(write-region (point-min) (point-max) file nil 'silent)
(kill-buffer (current-buffer))))
(gnus-message 4 "Saved"))
(provide 'gnus-edit)
;;; gnus-edit.el end here

242
lisp/gnus-ems.el
View file

@ -1,242 +0,0 @@
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
(defvar gnus-mouse-2 [mouse-2])
(defalias 'gnus-make-overlay 'make-overlay)
(defalias 'gnus-overlay-put 'overlay-put)
(defalias 'gnus-move-overlay 'move-overlay)
(defalias 'gnus-overlay-end 'overlay-end)
(defalias 'gnus-extent-detached-p 'ignore)
(defalias 'gnus-extent-start-open 'ignore)
(defalias 'gnus-set-text-properties 'set-text-properties)
(defalias 'gnus-group-remove-excess-properties 'ignore)
(defalias 'gnus-topic-remove-excess-properties 'ignore)
(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
(defalias 'gnus-make-local-hook 'make-local-hook)
(defalias 'gnus-add-hook 'add-hook)
(defalias 'gnus-character-to-event 'identity)
(defalias 'gnus-add-text-properties 'add-text-properties)
(defalias 'gnus-put-text-property 'put-text-property)
(defalias 'gnus-mode-line-buffer-identification 'identity)
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
(autoload 'appt-select-lowest-window "appt.el"))
(or (fboundp 'mail-file-babyl-p)
(fset 'mail-file-babyl-p 'rmail-file-p))
;;; Mule functions.
(defun gnus-mule-cite-add-face (number prefix face)
;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
(if face
(let ((inhibit-point-motion-hooks t)
from to)
(goto-line number)
(if (boundp 'MULE)
(forward-char (chars-in-string prefix))
(forward-char (length prefix)))
(skip-chars-forward " \t")
(setq from (point))
(end-of-line 1)
(skip-chars-backward " \t")
(setq to (point))
(if (< from to)
(gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
(defun gnus-mule-max-width-function (el max-width)
(` (let* ((val (eval (, el)))
(valstr (if (numberp val)
(int-to-string val) val)))
(if (> (length valstr) (, max-width))
(truncate-string valstr (, max-width))
valstr))))
(eval-and-compile
(if (string-match "XEmacs\\|Lucid" emacs-version)
()
(defvar gnus-mouse-face-prop 'mouse-face
"Property used for highlighting mouse regions.")
(defvar gnus-article-x-face-command
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
"String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command.")
;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
(defvar gnus-display-type
(condition-case nil
(let ((display-resource (x-get-resource ".displayType" "DisplayType")))
(cond (display-resource (intern (downcase display-resource)))
((x-display-color-p) 'color)
((x-display-grayscale-p) 'grayscale)
(t 'mono)))
(error 'mono))
"A symbol indicating the display Emacs is running under.
The symbol should be one of `color', `grayscale' or `mono'. If Emacs
guesses this display attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.displayType' in your
`~/.Xdefaults'. See also `gnus-background-mode'.
This is a meta-variable that will affect what default values other
variables get. You would normally not change this variable, but
pounce directly on the real variables themselves.")
(defvar gnus-background-mode
(condition-case nil
(let ((bg-resource (x-get-resource ".backgroundMode"
"BackgroundMode"))
(params (frame-parameters)))
(cond (bg-resource (intern (downcase bg-resource)))
((and (cdr (assq 'background-color params))
(< (apply '+ (x-color-values
(cdr (assq 'background-color params))))
(* (apply '+ (x-color-values "white")) .6)))
'dark)
(t 'light)))
(error 'light))
"A symbol indicating the Emacs background brightness.
The symbol should be one of `light' or `dark'.
If Emacs guesses this frame attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
`~/.Xdefaults'.
See also `gnus-display-type'.
This is a meta-variable that will affect what default values other
variables get. You would normally not change this variable, but
pounce directly on the real variables themselves."))
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
(gnus-xmas-define))
((or (not (boundp 'emacs-minor-version))
(< emacs-minor-version 30))
;; Remove the `intangible' prop.
(let ((props (and (boundp 'gnus-hidden-properties)
gnus-hidden-properties)))
(while (and props (not (eq (car (cdr props)) 'intangible)))
(setq props (cdr props)))
(and props (setcdr props (cdr (cdr (cdr props))))))
(or (fboundp 'buffer-substring-no-properties)
(defun buffer-substring-no-properties (beg end)
(format "%s" (buffer-substring beg end)))))
((boundp 'MULE)
(provide 'gnusutil))))
(eval-and-compile
(cond
((not window-system)
(defun gnus-dummy-func (&rest args))
(let ((funcs '(mouse-set-point set-face-foreground
set-face-background x-popup-menu)))
(while funcs
(or (fboundp (car funcs))
(fset (car funcs) 'gnus-dummy-func))
(setq funcs (cdr funcs))))))
(or (fboundp 'file-regular-p)
(defun file-regular-p (file)
(and (not (file-directory-p file))
(not (file-symlink-p file))
(file-exists-p file))))
(or (fboundp 'face-list)
(defun face-list (&rest args))))
(eval-and-compile
(let ((case-fold-search t))
(cond
((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type))
(setq nnheader-file-name-translation-alist
(append nnheader-file-name-translation-alist
'((?: . ?_)
(?+ . ?-))))))))
(defvar gnus-tmp-unread)
(defvar gnus-tmp-replied)
(defvar gnus-tmp-score-char)
(defvar gnus-tmp-indentation)
(defvar gnus-tmp-opening-bracket)
(defvar gnus-tmp-lines)
(defvar gnus-tmp-name)
(defvar gnus-tmp-closing-bracket)
(defvar gnus-tmp-subject-or-nil)
(defun gnus-ems-redefine ()
(cond
((string-match "XEmacs\\|Lucid" emacs-version)
(gnus-xmas-redefine))
((boundp 'MULE)
;; Mule definitions
(defalias 'gnus-truncate-string 'truncate-string)
(fset 'gnus-summary-make-display-table (lambda () nil))
(fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
(fset 'gnus-max-width-function 'gnus-mule-max-width-function)
(if (boundp 'gnus-check-before-posting)
(setq gnus-check-before-posting
(delq 'long-lines
(delq 'control-chars gnus-check-before-posting))))
(defun gnus-summary-line-format-spec ()
(insert gnus-tmp-unread gnus-tmp-replied
gnus-tmp-score-char gnus-tmp-indentation)
(put-text-property
(point)
(progn
(insert
gnus-tmp-opening-bracket
(format "%4d: %-20s"
gnus-tmp-lines
(if (> (length gnus-tmp-name) 20)
(truncate-string gnus-tmp-name 20)
gnus-tmp-name))
gnus-tmp-closing-bracket)
(point))
gnus-mouse-face-prop gnus-mouse-face)
(insert " " gnus-tmp-subject-or-nil "\n"))
)))
(provide 'gnus-ems)
;; Local Variables:
;; byte-compile-warnings: '(redefine callargs)
;; End:
;;; gnus-ems.el ends here

872
lisp/gnus-gl.el
View file

@ -1,872 +0,0 @@
;;; gnus-gl.el --- an interface to GroupLens for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Brad Miller <bmiller@cs.umn.edu>
;; Keywords: news, score
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GroupLens software and documentation is copyright (c) 1995 by Paul
;; Resnick (Massachusetts Institute of Technology); Brad Miller, John
;; Riedl, Jon Herlocker, and Joseph Konstan (University of Minnesota),
;; and David Maltz (Carnegie-Mellon University).
;;
;; Permission to use, copy, modify, and distribute this documentation
;; for non-commercial and commercial purposes without fee is hereby
;; granted provided that this copyright notice and permission notice
;; appears in all copies and that the names of the individuals and
;; institutions holding this copyright are not used in advertising or
;; publicity pertaining to this software without specific, written
;; prior permission. The copyright holders make no representations
;; about the suitability of this software and documentation for any
;; purpose. It is provided ``as is'' without express or implied
;; warranty.
;;
;; The copyright holders request that they be notified of
;; modifications of this code. Please send electronic mail to
;; grouplens@cs.umn.edu for more information or to announce derived
;; works.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Author: Brad Miller
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; User Documentation:
;; To use GroupLens you must load this file.
;; You must also register a pseudonym with the Better Bit Bureau.
;; http://www.cs.umn.edu/Research/GroupLens
;;
;; ---------------- For your .emacs or .gnus file ----------------
;;
;; As of version 2.5, grouplens now works as a minor mode of
;; gnus-summary-mode. To get make that work you just need a couple of
;; hooks.
;; (setq gnus-use-grouplens t)
;; (setq grouplens-pseudonym "")
;; (setq grouplens-bbb-host "grouplens.cs.umn.edu")
;;
;; (setq gnus-summary-default-score 0)
;;
;; USING GROUPLENS
;; How do I Rate an article??
;; Before you type n to go to the next article, hit a number from 1-5
;; Type r in the summary buffer and you will be prompted.
;; Note that when you're in grouplens-minor-mode 'r' maskes the
;; usual reply binding for 'r'
;;
;; What if, Gasp, I find a bug???
;; Please type M-x gnus-gl-submit-bug-report. This will set up a
;; mail buffer with the state of variables and buffers that will help
;; me debug the problem. A short description up front would help too!
;;
;; How do I display the prediction for an aritcle:
;; If you set the gnus-summary-line-format as shown above, the score
;; (prediction) will be shown automatically.
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Programmer Notes
;; 10/9/95
;; gnus-scores-articles contains the articles
;; When scoring is done, the call tree looks something like:
;; gnus-possibly-score-headers
;; ==> gnus-score-headers
;; ==> gnus-score-load-file
;; ==> get-all-mids (from the eval form)
;;
;; it would be nice to have one that gets called after all the other
;; headers have been scored.
;; we may want a variable gnus-grouplens-scale-factor
;; and gnus-grouplens-offset this would probably be either -3 or 0
;; to make the scores centered around zero or not.
;; Notes 10/12/95
;; According to Lars, Norse god of gnus, the simple way to insert a
;; call to an external function is to have a function added to the
;; variable gnus-score-find-files-function This new function
;; gnus-grouplens-score-alist will return a core alist that
;; has (("message-id" ("<message-id-xxxx>" score) ("<message-id-xxxy>" score))
;; This seems like it would be pretty inefficient, though workable.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 3. Add some more ways to rate messages
;; 4. Better error handling for token timeouts.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bugs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:
(require 'gnus-score)
(require 'cl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; User variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar gnus-summary-grouplens-line-format
"%U%R%z%l%I%(%[%4L: %-20,20n%]%) %s\n"
"*The line format spec in summary GroupLens mode buffers.")
(defvar grouplens-pseudonym ""
"User's pseudonym. This pseudonym is obtained during the registration process")
(defvar grouplens-bbb-host "grouplens.cs.umn.edu"
"Host where the bbbd is running" )
(defvar grouplens-bbb-port 9000
"Port where the bbbd is listening" )
(defvar grouplens-newsgroups
'("comp.lang.c++" "rec.humor" "rec.food.recipes" "comp.groupware"
"mn.general" "rec.arts.movies" "rec.arts.movies.current-films"
"comp.lang.java" "comp.os.linux.announce" "comp.os.linux.misc"
"comp.os.linux.development.apps" "comp.os.linux.development.system")
"*Groups that are part of the GroupLens experiment.")
(defvar grouplens-prediction-display 'prediction-spot
"valid values are:
prediction-spot -- an * corresponding to the prediction between 1 and 5,
confidence-interval -- a numeric confidence interval
prediction-bar -- |##### | the longer the bar, the better the article,
confidence-bar -- | ----- } the prediction is in the middle of the bar,
confidence-spot -- ) * | the spot gets bigger with more confidence,
prediction-num -- plain-old numeric value,
confidence-plus-minus -- prediction +/i confidence")
(defvar grouplens-score-offset 0
"Offset the prediction by this value.
Setting this variable to -2 would have the following effect on
GroupLens scores:
1 --> -2
2 --> -1
3 --> 0
4 --> 1
5 --> 2
The reason is that a user might want to do this is to combine
GroupLens predictions with scores calculated by other score methods.")
(defvar grouplens-score-scale-factor 1
"This variable allows the user to magnify the effect of GroupLens scores.
The scale factor is applied after the offset.")
(defvar gnus-grouplens-override-scoring 'override
"Tell Grouplens to override the normal Gnus scoring mechanism.
GroupLens scores can be combined with gnus scores in one of three ways.
'override -- just use grouplens predictions for grouplens groups
'combine -- combine grouplens scores with gnus scores
'separate -- treat grouplens scores completely separate from gnus")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Program global variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar grouplens-bbb-token "0"
"Current session token number")
(defvar grouplens-bbb-process nil
"Process Id of current bbbd network stream process")
(defvar grouplens-bbb-buffer nil
"Buffer associated with the BBBD process")
(defvar grouplens-rating-alist nil
"Current set of message-id rating pairs")
(defvar grouplens-current-hashtable (make-hash-table :test 'equal :size 100))
;; this seems like a pretty ugly way to get around the problem, but If
;; I don't do this, then the compiler complains when I call gethash
;;
(eval-when-compile (setq grouplens-current-hashtable
(make-hash-table :test 'equal :size 100)))
(defvar grouplens-current-group nil)
(defvar bbb-mid-list nil)
(defvar bbb-alist nil)
(defvar bbb-timeout-secs 10
"Number of seconds to wait for some response from the BBB.
If this times out we give up and assume that something has died..." )
(defvar grouplens-previous-article nil
"Message-ID of the last article read.")
(defvar bbb-read-point)
(defvar bbb-response-point)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Utility Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-connect-to-bbbd (host port)
(unless grouplens-bbb-buffer
(setq grouplens-bbb-buffer
(get-buffer-create (format " *BBBD trace: %s*" host)))
(save-excursion
(set-buffer grouplens-bbb-buffer)
(make-local-variable 'bbb-read-point)
(setq bbb-read-point (point-min))))
;; clear the trace buffer of old output
(save-excursion
(set-buffer grouplens-bbb-buffer)
(erase-buffer))
;; open the connection to the server
(setq grouplens-bbb-process nil)
(catch 'done
(condition-case error
(setq grouplens-bbb-process
(open-network-stream "BBBD" grouplens-bbb-buffer host port))
(error (gnus-message 3 "Error: Failed to connect to BBB")
nil))
(and (null grouplens-bbb-process)
(throw 'done nil))
;; (set-process-filter grouplens-bbb-process 'bbb-process-filter)
(save-excursion
(set-buffer grouplens-bbb-buffer)
(setq bbb-read-point (point-min))
(or (bbb-read-response grouplens-bbb-process)
(throw 'done nil))))
grouplens-bbb-process)
;; (defun bbb-process-filter (process output)
;; (save-excursion
;; (set-buffer (bbb-process-buffer process))
;; (goto-char (point-max))
;; (insert output)))
(defun bbb-send-command (process command)
(goto-char (point-max))
(insert command)
(insert "\r\n")
(setq bbb-read-point (point))
(setq bbb-response-point (point))
(set-marker (process-mark process) (point)) ; process output also comes here
(process-send-string process command)
(process-send-string process "\r\n"))
(defun bbb-read-response (process) ; &optional return-response-string)
"This function eats the initial response of OK or ERROR from the BBB."
(let ((case-fold-search nil)
match-end)
(goto-char bbb-read-point)
(while (and (not (search-forward "\r\n" nil t))
(accept-process-output process bbb-timeout-secs))
(goto-char bbb-read-point))
(setq match-end (point))
(goto-char bbb-read-point)
(setq bbb-read-point match-end)
(looking-at "OK")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Login Functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-login ()
"return the token number if login is successful, otherwise return nil"
(interactive)
(setq grouplens-bbb-token nil)
(if (not (equal grouplens-pseudonym ""))
(let ((bbb-process
(bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
(if bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(bbb-send-command bbb-process
(concat "login " grouplens-pseudonym))
(if (bbb-read-response bbb-process)
(setq grouplens-bbb-token (bbb-extract-token-number))
(gnus-message 3 "Error: Grouplens login failed")))))
(gnus-message 3 "Error: you must set a pseudonym"))
grouplens-bbb-token)
(defun bbb-extract-token-number ()
(let ((token-pos (search-forward "token=" nil t) ))
(if (looking-at "[0-9]+")
(buffer-substring token-pos (match-end 0)))))
(gnus-add-shutdown 'bbb-logout 'gnus)
(defun bbb-logout ()
"logout of bbb session"
(let ((bbb-process
(bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
(if bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(bbb-send-command bbb-process (concat "logout " grouplens-bbb-token))
(bbb-read-response bbb-process))
nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Get Predictions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bbb-build-mid-scores-alist (groupname)
"this function can be called as part of the function to return the
list of score files to use. See the gnus variable
gnus-score-find-score-files-function.
*Note:* If you want to use grouplens scores along with calculated scores,
you should see the offset and scale variables. At this point, I don't
recommend using both scores and grouplens predictions together."
(setq grouplens-current-group groupname)
(if (member groupname grouplens-newsgroups)
(let* ((mid-list (bbb-get-all-mids))
(predict-list (bbb-get-predictions mid-list groupname)))
(setq grouplens-previous-article nil)
;; scores-alist should be a list of lists:
;; ((("message-id" ("<mid1>" score1 nil s) ("<mid2> score2 nil s))))
;;`((("message-id" . ,predict-list))) ; Yes, this is the return value
(list (list (list (append (list "message-id") predict-list)))))
nil))
(defun bbb-get-predictions (midlist groupname)
"Ask the bbb for predictions, and build up the score alist."
(if (or (null grouplens-bbb-token)
(equal grouplens-bbb-token "0"))
(progn
(gnus-message 3 "Error: You are not logged in to a BBB")
nil)
(gnus-message 5 "Fetching Predictions...")
(let (predict-list
(predict-command (bbb-build-predict-command midlist groupname
grouplens-bbb-token))
(bbb-process (bbb-connect-to-bbbd grouplens-bbb-host
grouplens-bbb-port)))
(if bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(bbb-send-command bbb-process predict-command)
(if (bbb-read-response bbb-process)
(setq predict-list (bbb-get-prediction-response bbb-process))
(gnus-message 1 "Invalid Token, login and try again")
(ding))))
(setq bbb-alist predict-list))))
(defun bbb-get-all-mids ()
(let ((index (nth 1 (assoc "message-id" gnus-header-index)))
(articles gnus-newsgroup-headers)
art this)
(setq bbb-mid-list nil)
(while articles
(progn (setq art (car articles)
this (aref art index)
articles (cdr articles))
(setq bbb-mid-list (cons this bbb-mid-list))))
bbb-mid-list))
(defun bbb-build-predict-command (mlist grpname token)
(let ((cmd (concat "getpredictions " token " " grpname "\r\n"))
art)
(while mlist
(setq art (car mlist)
cmd (concat cmd art "\r\n")
mlist (cdr mlist)))
(setq cmd (concat cmd ".\r\n"))
cmd))
(defun bbb-get-prediction-response (process)
(let ((case-fold-search nil)
match-end)
(goto-char bbb-read-point)
(while (and (not (search-forward ".\r\n" nil t))
(accept-process-output process bbb-timeout-secs))
(goto-char bbb-read-point))
(setq match-end (point))
(goto-char (+ bbb-response-point 4)) ;; we ought to be right before OK
(bbb-build-response-alist)))
;; build-response-alist assumes that the cursor has been positioned at
;; the first line of the list of mid/rating pairs. For now we will
;; use a prediction of 99 to signify no prediction. Ultimately, we
;; should just ignore messages with no predictions.
(defun bbb-build-response-alist ()
(let ((resp nil)
(match-end (point)))
(setq grouplens-current-hashtable (make-hash-table :test 'equal :size 100))
(while
(cond ((looking-at "\\(<.*>\\) :nopred=")
(push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp)
(forward-line 1)
t)
((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)")
(push `(,(bbb-get-mid) ,(bbb-get-pred) nil s) resp)
(cl-puthash (bbb-get-mid)
(list (bbb-get-pred) (bbb-get-confl) (bbb-get-confh))
grouplens-current-hashtable)
(forward-line 1)
t)
((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)")
(push `(,(bbb-get-mid) ,(bbb-get-pred) nil s) resp)
(cl-puthash (bbb-get-mid)
(list (bbb-get-pred) 0 0)
grouplens-current-hashtable)
(forward-line 1)
t)
(t nil)))
resp))
;; these two functions assume that there is an active match lying
;; around. Where the first parenthesized expression is the
;; message-id, and the second is the prediction. Since gnus assumes
;; that scores are integer values?? we round the prediction.
(defun bbb-get-mid ()
(buffer-substring (match-beginning 1) (match-end 1)))
(defun bbb-get-pred ()
(let ((tpred (string-to-number (buffer-substring
(match-beginning 2)
(match-end 2)))))
(if (> tpred 0)
(round (* grouplens-score-scale-factor (+ grouplens-score-offset tpred)))
1)))
(defun bbb-get-confl ()
(string-to-number (buffer-substring (match-beginning 3) (match-end 3))))
(defun bbb-get-confh ()
(string-to-number (buffer-substring (match-beginning 4) (match-end 4))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Prediction Display
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst grplens-rating-range 4.0)
(defconst grplens-maxrating 5)
(defconst grplens-minrating 1)
(defconst grplens-predstringsize 12)
(defvar gnus-tmp-score)
(defun bbb-grouplens-score (header)
(if (eq gnus-grouplens-override-scoring 'separate)
(bbb-grouplens-other-score header)
(let* ((rate-string (make-string 12 ? ))
(mid (aref header (nth 1 (assoc "message-id" gnus-header-index))))
(hashent (gethash mid grouplens-current-hashtable))
(iscore gnus-tmp-score)
(low (car (cdr hashent)))
(high (car (cdr (cdr hashent)))))
(aset rate-string 0 ?|)
(aset rate-string 11 ?|)
(unless (member grouplens-current-group grouplens-newsgroups)
(unless (equal grouplens-prediction-display 'prediction-num)
(cond ((< iscore 0)
(setq iscore 1))
((> iscore 5)
(setq iscore 5))))
(setq low 0)
(setq high 0))
(if (and (bbb-valid-score iscore)
(not (null mid)))
(cond
;; prediction-spot
((equal grouplens-prediction-display 'prediction-spot)
(setq rate-string (bbb-fmt-prediction-spot rate-string iscore)))
;; confidence-interval
((equal grouplens-prediction-display 'confidence-interval)
(setq rate-string (bbb-fmt-confidence-interval iscore low high)))
;; prediction-bar
((equal grouplens-prediction-display 'prediction-bar)
(setq rate-string (bbb-fmt-prediction-bar rate-string iscore)))
;; confidence-bar
((equal grouplens-prediction-display 'confidence-bar)
(setq rate-string (format "| %4.2f |" iscore)))
;; confidence-spot
((equal grouplens-prediction-display 'confidence-spot)
(setq rate-string (format "| %4.2f |" iscore)))
;; prediction-num
((equal grouplens-prediction-display 'prediction-num)
(setq rate-string (bbb-fmt-prediction-num iscore)))
;; confidence-plus-minus
((equal grouplens-prediction-display 'confidence-plus-minus)
(setq rate-string (bbb-fmt-confidence-plus-minus iscore low high))
)
(t (gnus-message 3 "Invalid prediction display type")))
(aset rate-string 5 ?N) (aset rate-string 6 ?A))
rate-string)))
;;
;; Gnus user format function that doesn't depend on
;; bbb-build-mid-scores-alist being used as the score function, but is
;; instead called from gnus-select-group-hook. -- LAB
(defun bbb-grouplens-other-score (header)
(if (not (member grouplens-current-group grouplens-newsgroups))
;; Return an empty string
""
(let* ((rate-string (make-string 12 ? ))
(mid (aref header (nth 1 (assoc "message-id" gnus-header-index))))
(hashent (gethash mid grouplens-current-hashtable))
(pred (or (nth 0 hashent) 0))
(low (nth 1 hashent))
(high (nth 2 hashent)))
;; Init rate-string
(aset rate-string 0 ?|)
(aset rate-string 11 ?|)
(unless (equal grouplens-prediction-display 'prediction-num)
(cond ((< pred 0)
(setq pred 1))
((> pred 5)
(setq pred 5))))
;; If no entry in BBB hash mark rate string as NA and return
(cond
((null hashent)
(aset rate-string 5 ?N)
(aset rate-string 6 ?A)
rate-string)
((equal grouplens-prediction-display 'prediction-spot)
(bbb-fmt-prediction-spot rate-string pred))
((equal grouplens-prediction-display 'confidence-interval)
(bbb-fmt-confidence-interval pred low high))
((equal grouplens-prediction-display 'prediction-bar)
(bbb-fmt-prediction-bar rate-string pred))
((equal grouplens-prediction-display 'confidence-bar)
(format "| %4.2f |" pred))
((equal grouplens-prediction-display 'confidence-spot)
(format "| %4.2f |" pred))
((equal grouplens-prediction-display 'prediction-num)
(bbb-fmt-prediction-num pred))
((equal grouplens-prediction-display 'confidence-plus-minus)
(bbb-fmt-confidence-plus-minus pred low high))
(t
(gnus-message 3 "Invalid prediction display type")
(aset rate-string 0 ?|)
(aset rate-string 11 ?|)
rate-string)))))
(defun bbb-valid-score (score)
(or (equal grouplens-prediction-display 'prediction-num)
(and (>= score grplens-minrating)
(<= score grplens-maxrating))))
(defun bbb-requires-confidence (format-type)
(or (equal format-type 'confidence-plus-minus)
(equal format-type 'confidence-spot)
(equal format-type 'confidence-interval)))
(defun bbb-have-confidence (clow chigh)
(not (or (null clow)
(null chigh))))
(defun bbb-fmt-prediction-spot (rate-string score)
(aset rate-string
(round (* (/ (- score grplens-minrating) grplens-rating-range)
(+ (- grplens-predstringsize 4) 1.49)))
?*)
rate-string)
(defun bbb-fmt-confidence-interval (score low high)
(if (bbb-have-confidence low high)
(format "|%4.2f-%4.2f |" low high)
(bbb-fmt-prediction-num score)))
(defun bbb-fmt-confidence-plus-minus (score low high)
(if (bbb-have-confidence low high)
(format "|%3.1f+/-%4.2f|" score (/ (- high low) 2.0))
(bbb-fmt-prediction-num score)))
(defun bbb-fmt-prediction-bar (rate-string score)
(let* ((i 1)
(step (/ grplens-rating-range (- grplens-predstringsize 4)))
(half-step (/ step 2))
(loc (- grplens-minrating half-step)))
(while (< i (- grplens-predstringsize 2))
(if (> score loc)
(aset rate-string i ?#)
(aset rate-string i ? ))
(setq i (+ i 1))
(setq loc (+ loc step)))
)
rate-string)
(defun bbb-fmt-prediction-num (score)
(format "| %4.2f |" score))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Put Ratings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The message-id for the current article can be found in
;; (aref gnus-current-headers (nth 1 (assoc "message-id" gnus-header-index)))
(defun bbb-put-ratings ()
(if (and grouplens-rating-alist
(member gnus-newsgroup-name grouplens-newsgroups))
(let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host
grouplens-bbb-port))
(rate-command (bbb-build-rate-command grouplens-rating-alist)))
(if bbb-process
(save-excursion
(set-buffer (process-buffer bbb-process))
(gnus-message 5 "Sending Ratings...")
(bbb-send-command bbb-process rate-command)
(if (bbb-read-response bbb-process)
(setq grouplens-rating-alist nil)
(gnus-message 1
"Token timed out: call bbb-login and quit again")
(ding))
(gnus-message 5 "Sending Ratings...Done"))
(gnus-message 3 "No BBB connection")))
(setq grouplens-rating-alist nil)))
(defun bbb-build-rate-command (rate-alist)
(let (this
(cmd (concat "putratings " grouplens-bbb-token
" " grouplens-current-group " \r\n")))
(while rate-alist
(setq this (car rate-alist)
cmd (concat cmd (car this) " :rating=" (cadr this) ".00"
" :time=" (cddr this) "\r\n")
rate-alist (cdr rate-alist)))
(concat cmd ".\r\n")))
;; Interactive rating functions.
(defun bbb-summary-rate-article (rating &optional midin)
(interactive "nRating: ")
(when (member gnus-newsgroup-name grouplens-newsgroups)
(let ((mid (or midin (bbb-get-current-id))))
(if (and rating
(>= rating grplens-minrating)
(<= rating grplens-maxrating)
mid)
(let ((oldrating (assoc mid grouplens-rating-alist)))
(if oldrating
(setcdr oldrating (cons rating 0))
(push `(,mid . (,rating . 0)) grouplens-rating-alist))
(gnus-summary-mark-article nil (int-to-string rating)))
(gnus-message 3 "Invalid rating")))))
(defun grouplens-next-unread-article (rating)
"Select unread article after current one."
(interactive "P")
(if rating (bbb-summary-rate-article rating))
(gnus-summary-next-unread-article))
(defun grouplens-best-unread-article (rating)
"Select unread article after current one."
(interactive "P")
(if rating (bbb-summary-rate-article rating))
(gnus-summary-best-unread-article))
(defun grouplens-summary-catchup-and-exit (rating)
"Mark all articles not marked as unread in this newsgroup as read,
then exit. If prefix argument ALL is non-nil, all articles are
marked as read."
(interactive "P")
(if rating
(bbb-summary-rate-article rating))
(if (numberp rating)
(gnus-summary-catchup-and-exit)
(gnus-summary-catchup-and-exit rating)))
(defun grouplens-score-thread (score)
"Raise the score of the articles in the current thread with SCORE."
(interactive "nRating: ")
(let (e)
(save-excursion
(let ((articles (gnus-summary-articles-in-thread)))
(while articles
(gnus-summary-goto-subject (car articles))
(gnus-set-global-variables)
(bbb-summary-rate-article score
(mail-header-id
(gnus-summary-article-header
(car articles))))
(setq articles (cdr articles))))
(setq e (point)))
(let ((gnus-summary-check-current t))
(or (zerop (gnus-summary-next-subject 1 t))
(goto-char e))))
(gnus-summary-recenter)
(gnus-summary-position-point)
(gnus-set-mode-line 'summary))
(defun bbb-get-current-id ()
(if gnus-current-headers
(aref gnus-current-headers
(nth 1 (assoc "message-id" gnus-header-index)))
(gnus-message 3 "You must select an article before you rate it")))
(defun bbb-grouplens-group-p (group)
"Say whether GROUP is a GroupLens group."
(if (member group grouplens-newsgroups) " (GroupLens Enhanced)" ""))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TIME SPENT READING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar grouplens-current-starting-time nil)
(defun grouplens-start-timer ()
(setq grouplens-current-starting-time (current-time)))
(defun grouplens-elapsed-time ()
(let ((et (bbb-time-float (current-time))))
(- et (bbb-time-float grouplens-current-starting-time))))
(defun bbb-time-float (timeval)
(+ (* (car timeval) 65536)
(cadr timeval)))
(defun grouplens-do-time ()
(when (member gnus-newsgroup-name grouplens-newsgroups)
(when grouplens-previous-article
(let ((elapsed-time (grouplens-elapsed-time))
(oldrating (assoc grouplens-previous-article
grouplens-rating-alist)))
(if (not oldrating)
(push `(,grouplens-previous-article . (0 . ,elapsed-time))
grouplens-rating-alist)
(setcdr oldrating (cons (cadr oldrating) elapsed-time)))))
(grouplens-start-timer)
(setq grouplens-previous-article (bbb-get-current-id))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BUG REPORTING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst gnus-gl-version "gnus-gl.el 2.12")
(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu")
(defun gnus-gl-submit-bug-report ()
"Submit via mail a bug report on gnus-gl"
(interactive)
(require 'reporter)
(reporter-submit-bug-report gnus-gl-maintainer-address
(concat "gnus-gl.el " gnus-gl-version)
(list 'grouplens-pseudonym
'grouplens-bbb-host
'grouplens-bbb-port
'grouplens-newsgroups
'grouplens-bbb-token
'grouplens-bbb-process
'grouplens-current-group
'grouplens-previous-article
'grouplens-mid-list
'bbb-alist)
nil
'gnus-gl-get-trace))
(defun gnus-gl-get-trace ()
"Insert the contents of the BBBD trace buffer"
(if grouplens-bbb-buffer (insert-buffer grouplens-bbb-buffer)))
;;;
;;; Additions to make gnus-grouplens-mode Warning Warning!!
;;; This version of the gnus-grouplens-mode does
;;; not work with gnus-5.x. The "old" way of
;;; setting up GroupLens still works however.
;;;
(defvar gnus-grouplens-mode nil
"Minor mode for providing a GroupLens interface in Gnus summary buffers.")
(defvar gnus-grouplens-mode-map nil)
(unless gnus-grouplens-mode-map
(setq gnus-grouplens-mode-map (make-keymap))
(gnus-define-keys
gnus-grouplens-mode-map
"n" grouplens-next-unread-article
"r" bbb-summary-rate-article
"k" grouplens-score-thread
"c" grouplens-summary-catchup-and-exit
"," grouplens-best-unread-article))
(defun gnus-grouplens-make-menu-bar ()
(unless (boundp 'gnus-grouplens-menu)
(easy-menu-define
gnus-grouplens-menu gnus-grouplens-mode-map ""
'("GroupLens"
["Login" bbb-login t]
["Rate" bbb-summary-rate-article t]
["Next article" grouplens-next-unread-article t]
["Best article" grouplens-best-unread-article t]
["Raise thread" grouplens-score-thread t]
["Report bugs" gnus-gl-submit-bug-report t]))))
(defun gnus-grouplens-mode (&optional arg)
"Minor mode for providing a GroupLens interface in Gnus summary buffers."
(interactive "P")
(when (and (eq major-mode 'gnus-summary-mode)
(member gnus-newsgroup-name grouplens-newsgroups))
(make-local-variable 'gnus-grouplens-mode)
(setq gnus-grouplens-mode
(if (null arg) (not gnus-grouplens-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-grouplens-mode
(if (not (fboundp 'make-local-hook))
(add-hook 'gnus-select-article-hook 'grouplens-do-time)
(make-local-hook 'gnus-select-article-hook)
(add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local))
(if (not (fboundp 'make-local-hook))
(add-hook 'gnus-exit-group-hook 'bbb-put-ratings)
(make-local-hook 'gnus-exit-group-hook)
(add-hook 'gnus-exit-group-hook 'bbb-put-ratings nil 'local))
(make-local-variable 'gnus-score-find-score-files-function)
(cond ((eq gnus-grouplens-override-scoring 'combine)
;; either add bbb-buld-mid-scores-alist to a list
;; or make a list
(if (listp gnus-score-find-score-files-function)
(setq gnus-score-find-score-files-function
(append 'bbb-build-mid-scores-alist
gnus-score-find-score-files-function ))
(setq gnus-score-find-score-files-function
(list gnus-score-find-score-files-function
'bbb-build-mid-scores-alist))))
;; leave the gnus-score-find-score-files variable alone
((eq gnus-grouplens-override-scoring 'separate)
(add-hook 'gnus-select-group-hook
'(lambda()
(bbb-build-mid-scores-alist gnus-newsgroup-name))))
;; default is to override
(t (setq gnus-score-find-score-files-function
'bbb-build-mid-scores-alist)))
(make-local-variable 'gnus-summary-line-format)
(setq gnus-summary-line-format
gnus-summary-grouplens-line-format)
(make-local-variable 'gnus-summary-line-format-spec)
(setq gnus-summary-line-format-spec nil)
;; Set up the menu.
(when (and menu-bar-mode
(gnus-visual-p 'grouplens-menu 'menu))
(gnus-grouplens-make-menu-bar))
(unless (assq 'gnus-grouplens-mode minor-mode-alist)
(push '(gnus-grouplens-mode " GroupLens") minor-mode-alist))
(unless (assq 'gnus-grouplens-mode minor-mode-map-alist)
(push (cons 'gnus-grouplens-mode gnus-grouplens-mode-map)
minor-mode-map-alist))
(run-hooks 'gnus-grouplens-mode-hook))))
(provide 'gnus-gl)
;;; gnus-gl.el ends here

655
lisp/gnus-kill.el
View file

@ -1,655 +0,0 @@
;;; gnus-kill.el --- kill commands for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-kill-file-mode-hook nil
"*A hook for Gnus kill file mode.")
(defvar gnus-kill-expiry-days 7
"*Number of days before expiring unused kill file entries.")
(defvar gnus-kill-save-kill-file nil
"*If non-nil, will save kill files after processing them.")
(defvar gnus-winconf-kill-file nil)
(defmacro gnus-raise (field expression level)
`(gnus-kill ,field ,expression
(function (gnus-summary-raise-score ,level)) t))
(defmacro gnus-lower (field expression level)
`(gnus-kill ,field ,expression
(function (gnus-summary-raise-score (- ,level))) t))
;;;
;;; Gnus Kill File Mode
;;;
(defvar gnus-kill-file-mode-map nil)
(unless gnus-kill-file-mode-map
(gnus-define-keymap
(setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map))
"\C-c\C-k\C-s" gnus-kill-file-kill-by-subject
"\C-c\C-k\C-a" gnus-kill-file-kill-by-author
"\C-c\C-k\C-t" gnus-kill-file-kill-by-thread
"\C-c\C-k\C-x" gnus-kill-file-kill-by-xref
"\C-c\C-a" gnus-kill-file-apply-buffer
"\C-c\C-e" gnus-kill-file-apply-last-sexp
"\C-c\C-c" gnus-kill-file-exit))
(defun gnus-kill-file-mode ()
"Major mode for editing kill files.
If you are using this mode - you probably shouldn't. Kill files
perform badly and paint with a pretty broad brush. Score files, on
the other hand, are vastly faster (40x speedup) and give you more
control over what to do.
In addition to Emacs-Lisp Mode, the following commands are available:
\\{gnus-kill-file-mode-map}
A kill file contains Lisp expressions to be applied to a selected
newsgroup. The purpose is to mark articles as read on the basis of
some set of regexps. A global kill file is applied to every newsgroup,
and a local kill file is applied to a specified newsgroup. Since a
global kill file is applied to every newsgroup, for better performance
use a local one.
A kill file can contain any kind of Emacs Lisp expressions expected
to be evaluated in the Summary buffer. Writing Lisp programs for this
purpose is not so easy because the internal working of Gnus must be
well-known. For this reason, Gnus provides a general function which
does this easily for non-Lisp programmers.
The `gnus-kill' function executes commands available in Summary Mode
by their key sequences. `gnus-kill' should be called with FIELD,
REGEXP and optional COMMAND and ALL. FIELD is a string representing
the header field or an empty string. If FIELD is an empty string, the
entire article body is searched for. REGEXP is a string which is
compared with FIELD value. COMMAND is a string representing a valid
key sequence in Summary mode or Lisp expression. COMMAND defaults to
'(gnus-summary-mark-as-read nil \"X\"). Make sure that COMMAND is
executed in the Summary buffer. If the second optional argument ALL
is non-nil, the COMMAND is applied to articles which are already
marked as read or unread. Articles which are marked are skipped over
by default.
For example, if you want to mark articles of which subjects contain
the string `AI' as read, a possible kill file may look like:
(gnus-kill \"Subject\" \"AI\")
If you want to mark articles with `D' instead of `X', you can use
the following expression:
(gnus-kill \"Subject\" \"AI\" \"d\")
In this example it is assumed that the command
`gnus-summary-mark-as-read-forward' is assigned to `d' in Summary Mode.
It is possible to delete unnecessary headers which are marked with
`X' in a kill file as follows:
(gnus-expunge \"X\")
If the Summary buffer is empty after applying kill files, Gnus will
exit the selected newsgroup normally. If headers which are marked
with `D' are deleted in a kill file, it is impossible to read articles
which are marked as read in the previous Gnus sessions. Marks other
than `D' should be used for articles which should really be deleted.
Entry to this mode calls emacs-lisp-mode-hook and
gnus-kill-file-mode-hook with no arguments, if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map gnus-kill-file-mode-map)
(set-syntax-table emacs-lisp-mode-syntax-table)
(setq major-mode 'gnus-kill-file-mode)
(setq mode-name "Kill")
(lisp-mode-variables nil)
(run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook))
(defun gnus-kill-file-edit-file (newsgroup)
"Begin editing a kill file for NEWSGROUP.
If NEWSGROUP is nil, the global kill file is selected."
(interactive "sNewsgroup: ")
(let ((file (gnus-newsgroup-kill-file newsgroup)))
(gnus-make-directory (file-name-directory file))
;; Save current window configuration if this is first invocation.
(or (and (get-file-buffer file)
(get-buffer-window (get-file-buffer file)))
(setq gnus-winconf-kill-file (current-window-configuration)))
;; Hack windows.
(let ((buffer (find-file-noselect file)))
(cond ((get-buffer-window buffer)
(pop-to-buffer buffer))
((eq major-mode 'gnus-group-mode)
(gnus-configure-windows 'group) ;Take all windows.
(pop-to-buffer buffer))
((eq major-mode 'gnus-summary-mode)
(gnus-configure-windows 'article)
(pop-to-buffer gnus-article-buffer)
(bury-buffer gnus-article-buffer)
(switch-to-buffer buffer))
(t ;No good rules.
(find-file-other-window file))))
(gnus-kill-file-mode)))
;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
(defun gnus-kill-set-kill-buffer ()
(let* ((file (gnus-newsgroup-kill-file gnus-newsgroup-name))
(buffer (find-file-noselect file)))
(set-buffer buffer)
(gnus-kill-file-mode)
(bury-buffer buffer)))
(defun gnus-kill-file-enter-kill (field regexp &optional dont-move)
;; Enter kill file entry.
;; FIELD: String containing the name of the header field to kill.
;; REGEXP: The string to kill.
(save-excursion
(let (string)
(or (eq major-mode 'gnus-kill-file-mode)
(gnus-kill-set-kill-buffer))
(unless dont-move
(goto-char (point-max)))
(insert (setq string (format "(gnus-kill %S %S)\n" field regexp)))
(gnus-kill-file-apply-string string))))
(defun gnus-kill-file-kill-by-subject ()
"Kill by subject."
(interactive)
(gnus-kill-file-enter-kill
"Subject"
(if (vectorp gnus-current-headers)
(regexp-quote
(gnus-simplify-subject (mail-header-subject gnus-current-headers)))
"") t))
(defun gnus-kill-file-kill-by-author ()
"Kill by author."
(interactive)
(gnus-kill-file-enter-kill
"From"
(if (vectorp gnus-current-headers)
(regexp-quote (mail-header-from gnus-current-headers))
"") t))
(defun gnus-kill-file-kill-by-thread ()
"Kill by author."
(interactive)
(gnus-kill-file-enter-kill
"References"
(if (vectorp gnus-current-headers)
(regexp-quote (mail-header-id gnus-current-headers))
"")))
(defun gnus-kill-file-kill-by-xref ()
"Kill by Xref."
(interactive)
(let ((xref (and (vectorp gnus-current-headers)
(mail-header-xref gnus-current-headers)))
(start 0)
group)
(if xref
(while (string-match " \\([^ \t]+\\):" xref start)
(setq start (match-end 0))
(if (not (string=
(setq group
(substring xref (match-beginning 1) (match-end 1)))
gnus-newsgroup-name))
(gnus-kill-file-enter-kill
"Xref" (concat " " (regexp-quote group) ":") t)))
(gnus-kill-file-enter-kill "Xref" "" t))))
(defun gnus-kill-file-raise-followups-to-author (level)
"Raise score for all followups to the current author."
(interactive "p")
(let ((name (mail-header-from gnus-current-headers))
string)
(save-excursion
(gnus-kill-set-kill-buffer)
(goto-char (point-min))
(setq name (read-string (concat "Add " level
" to followup articles to: ")
(regexp-quote name)))
(setq
string
(format
"(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n"
"From" name level))
(insert string)
(gnus-kill-file-apply-string string))
(gnus-message
6 "Added temporary score file entry for followups to %s." name)))
(defun gnus-kill-file-apply-buffer ()
"Apply current buffer to current newsgroup."
(interactive)
(if (and gnus-current-kill-article
(get-buffer gnus-summary-buffer))
;; Assume newsgroup is selected.
(gnus-kill-file-apply-string (buffer-string))
(ding) (gnus-message 2 "No newsgroup is selected.")))
(defun gnus-kill-file-apply-string (string)
"Apply STRING to current newsgroup."
(interactive)
(let ((string (concat "(progn \n" string "\n)")))
(save-excursion
(save-window-excursion
(pop-to-buffer gnus-summary-buffer)
(eval (car (read-from-string string)))))))
(defun gnus-kill-file-apply-last-sexp ()
"Apply sexp before point in current buffer to current newsgroup."
(interactive)
(if (and gnus-current-kill-article
(get-buffer gnus-summary-buffer))
;; Assume newsgroup is selected.
(let ((string
(buffer-substring
(save-excursion (forward-sexp -1) (point)) (point))))
(save-excursion
(save-window-excursion
(pop-to-buffer gnus-summary-buffer)
(eval (car (read-from-string string))))))
(ding) (gnus-message 2 "No newsgroup is selected.")))
(defun gnus-kill-file-exit ()
"Save a kill file, then return to the previous buffer."
(interactive)
(save-buffer)
(let ((killbuf (current-buffer)))
;; We don't want to return to article buffer.
(and (get-buffer gnus-article-buffer)
(bury-buffer gnus-article-buffer))
;; Delete the KILL file windows.
(delete-windows-on killbuf)
;; Restore last window configuration if available.
(and gnus-winconf-kill-file
(set-window-configuration gnus-winconf-kill-file))
(setq gnus-winconf-kill-file nil)
;; Kill the KILL file buffer. Suggested by tale@pawl.rpi.edu.
(kill-buffer killbuf)))
;; For kill files
(defun gnus-Newsgroup-kill-file (newsgroup)
"Return the name of a kill file for NEWSGROUP.
If NEWSGROUP is nil, return the global kill file instead."
(cond ((or (null newsgroup)
(string-equal newsgroup ""))
;; The global kill file is placed at top of the directory.
(expand-file-name gnus-kill-file-name gnus-kill-files-directory))
(gnus-use-long-file-name
;; Append ".KILL" to capitalized newsgroup name.
(expand-file-name (concat (gnus-capitalize-newsgroup newsgroup)
"." gnus-kill-file-name)
gnus-kill-files-directory))
(t
;; Place "KILL" under the hierarchical directory.
(expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
"/" gnus-kill-file-name)
gnus-kill-files-directory))))
(defun gnus-expunge (marks)
"Remove lines marked with MARKS."
(save-excursion
(set-buffer gnus-summary-buffer)
(gnus-summary-limit-to-marks marks 'reverse)))
(defun gnus-apply-kill-file-unless-scored ()
"Apply .KILL file, unless a .SCORE file for the same newsgroup exists."
(cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name))
;; Ignores global KILL.
(if (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))
(gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE"
gnus-newsgroup-name))
0)
((or (file-exists-p (gnus-newsgroup-kill-file nil))
(file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
(gnus-apply-kill-file-internal))
(t
0)))
(defun gnus-apply-kill-file-internal ()
"Apply a kill file to the current newsgroup.
Returns the number of articles marked as read."
(let* ((kill-files (list (gnus-newsgroup-kill-file nil)
(gnus-newsgroup-kill-file gnus-newsgroup-name)))
(unreads (length gnus-newsgroup-unreads))
(gnus-summary-inhibit-highlight t)
beg)
(setq gnus-newsgroup-kill-headers nil)
;; If there are any previously scored articles, we remove these
;; from the `gnus-newsgroup-headers' list that the score functions
;; will see. This is probably pretty wasteful when it comes to
;; conses, but is, I think, faster than having to assq in every
;; single score function.
(let ((files kill-files))
(while files
(if (file-exists-p (car files))
(let ((headers gnus-newsgroup-headers))
(if gnus-kill-killed
(setq gnus-newsgroup-kill-headers
(mapcar (lambda (header) (mail-header-number header))
headers))
(while headers
(or (gnus-member-of-range
(mail-header-number (car headers))
gnus-newsgroup-killed)
(setq gnus-newsgroup-kill-headers
(cons (mail-header-number (car headers))
gnus-newsgroup-kill-headers)))
(setq headers (cdr headers))))
(setq files nil))
(setq files (cdr files)))))
(if (not gnus-newsgroup-kill-headers)
()
(save-window-excursion
(save-excursion
(while kill-files
(if (not (file-exists-p (car kill-files)))
()
(gnus-message 6 "Processing kill file %s..." (car kill-files))
(find-file (car kill-files))
(gnus-add-current-to-buffer-list)
(goto-char (point-min))
(if (consp (condition-case nil (read (current-buffer))
(error nil)))
(gnus-kill-parse-gnus-kill-file)
(gnus-kill-parse-rn-kill-file))
(gnus-message
6 "Processing kill file %s...done" (car kill-files)))
(setq kill-files (cdr kill-files)))))
(gnus-set-mode-line 'summary)
(if beg
(let ((nunreads (- unreads (length gnus-newsgroup-unreads))))
(or (eq nunreads 0)
(gnus-message 6 "Marked %d articles as read" nunreads))
nunreads)
0))))
;; Parse a Gnus killfile.
(defun gnus-score-insert-help (string alist idx)
(save-excursion
(pop-to-buffer "*Score Help*")
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert string ":\n\n")
(while alist
(insert (format " %c: %s\n" (caar alist) (nth idx (car alist))))
(setq alist (cdr alist)))))
(defun gnus-kill-parse-gnus-kill-file ()
(goto-char (point-min))
(gnus-kill-file-mode)
(let (beg form)
(while (progn
(setq beg (point))
(setq form (condition-case () (read (current-buffer))
(error nil))))
(or (listp form)
(error "Illegal kill entry (possibly rn kill file?): %s" form))
(if (or (eq (car form) 'gnus-kill)
(eq (car form) 'gnus-raise)
(eq (car form) 'gnus-lower))
(progn
(delete-region beg (point))
(insert (or (eval form) "")))
(save-excursion
(set-buffer gnus-summary-buffer)
(condition-case () (eval form) (error nil)))))
(and (buffer-modified-p)
gnus-kill-save-kill-file
(save-buffer))
(set-buffer-modified-p nil)))
;; Parse an rn killfile.
(defun gnus-kill-parse-rn-kill-file ()
(goto-char (point-min))
(gnus-kill-file-mode)
(let ((mod-to-header
'((?a . "")
(?h . "")
(?f . "from")
(?: . "subject")))
(com-to-com
'((?m . " ")
(?j . "X")))
pattern modifier commands)
(while (not (eobp))
(if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)"))
()
(setq pattern (buffer-substring (match-beginning 1) (match-end 1)))
(setq modifier (if (match-beginning 2) (char-after (match-beginning 2))
?s))
(setq commands (buffer-substring (match-beginning 3) (match-end 3)))
;; The "f:+" command marks everything *but* the matches as read,
;; so we simply first match everything as read, and then unmark
;; PATTERN later.
(and (string-match "\\+" commands)
(progn
(gnus-kill "from" ".")
(setq commands "m")))
(gnus-kill
(or (cdr (assq modifier mod-to-header)) "subject")
pattern
(if (string-match "m" commands)
'(gnus-summary-mark-as-unread nil " ")
'(gnus-summary-mark-as-read nil "X"))
nil t))
(forward-line 1))))
;; Kill changes and new format by suggested by JWZ and Sudish Joseph
;; <joseph@cis.ohio-state.edu>.
(defun gnus-kill (field regexp &optional exe-command all silent)
"If FIELD of an article matches REGEXP, execute COMMAND.
Optional 1st argument COMMAND is default to
(gnus-summary-mark-as-read nil \"X\").
If optional 2nd argument ALL is non-nil, articles marked are also applied to.
If FIELD is an empty string (or nil), entire article body is searched for.
COMMAND must be a lisp expression or a string representing a key sequence."
;; We don't want to change current point nor window configuration.
(let ((old-buffer (current-buffer)))
(save-excursion
(save-window-excursion
;; Selected window must be summary buffer to execute keyboard
;; macros correctly. See command_loop_1.
(switch-to-buffer gnus-summary-buffer 'norecord)
(goto-char (point-min)) ;From the beginning.
(let ((kill-list regexp)
(date (current-time-string))
(command (or exe-command '(gnus-summary-mark-as-read
nil gnus-kill-file-mark)))
kill kdate prev)
(if (listp kill-list)
;; It is a list.
(if (not (consp (cdr kill-list)))
;; It's of the form (regexp . date).
(if (zerop (gnus-execute field (car kill-list)
command nil (not all)))
(if (> (gnus-days-between date (cdr kill-list))
gnus-kill-expiry-days)
(setq regexp nil))
(setcdr kill-list date))
(while (setq kill (car kill-list))
(if (consp kill)
;; It's a temporary kill.
(progn
(setq kdate (cdr kill))
(if (zerop (gnus-execute
field (car kill) command nil (not all)))
(if (> (gnus-days-between date kdate)
gnus-kill-expiry-days)
;; Time limit has been exceeded, so we
;; remove the match.
(if prev
(setcdr prev (cdr kill-list))
(setq regexp (cdr regexp))))
;; Successful kill. Set the date to today.
(setcdr kill date)))
;; It's a permanent kill.
(gnus-execute field kill command nil (not all)))
(setq prev kill-list)
(setq kill-list (cdr kill-list))))
(gnus-execute field kill-list command nil (not all))))))
(switch-to-buffer old-buffer)
(if (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent))
(gnus-pp-gnus-kill
(nconc (list 'gnus-kill field
(if (consp regexp) (list 'quote regexp) regexp))
(if (or exe-command all) (list (list 'quote exe-command)))
(if all (list t) nil))))))
(defun gnus-pp-gnus-kill (object)
(if (or (not (consp (nth 2 object)))
(not (consp (cdr (nth 2 object))))
(and (eq 'quote (car (nth 2 object)))
(not (consp (cdadr (nth 2 object))))))
(concat "\n" (prin1-to-string object))
(save-excursion
(set-buffer (get-buffer-create "*Gnus PP*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert (format "\n(%S %S\n '(" (nth 0 object) (nth 1 object)))
(let ((klist (cadr (nth 2 object)))
(first t))
(while klist
(insert (if first (progn (setq first nil) "") "\n ")
(prin1-to-string (car klist)))
(setq klist (cdr klist))))
(insert ")")
(and (nth 3 object)
(insert "\n "
(if (and (consp (nth 3 object))
(not (eq 'quote (car (nth 3 object)))))
"'" "")
(prin1-to-string (nth 3 object))))
(and (nth 4 object)
(insert "\n t"))
(insert ")")
(prog1
(buffer-substring (point-min) (point-max))
(kill-buffer (current-buffer))))))
(defun gnus-execute-1 (function regexp form header)
(save-excursion
(let (did-kill)
(if (null header)
nil ;Nothing to do.
(if function
;; Compare with header field.
(let (value)
(and header
(progn
(setq value (funcall function header))
;; Number (Lines:) or symbol must be converted to string.
(or (stringp value)
(setq value (prin1-to-string value)))
(setq did-kill (string-match regexp value)))
(cond ((stringp form) ;Keyboard macro.
(execute-kbd-macro form))
((gnus-functionp form)
(funcall form))
(t
(eval form)))))
;; Search article body.
(let ((gnus-current-article nil) ;Save article pointer.
(gnus-last-article nil)
(gnus-break-pages nil) ;No need to break pages.
(gnus-mark-article-hook nil)) ;Inhibit marking as read.
(gnus-message
6 "Searching for article: %d..." (mail-header-number header))
(gnus-article-setup-buffer)
(gnus-article-prepare (mail-header-number header) t)
(if (save-excursion
(set-buffer gnus-article-buffer)
(goto-char (point-min))
(setq did-kill (re-search-forward regexp nil t)))
(if (stringp form) ;Keyboard macro.
(execute-kbd-macro form)
(eval form))))))
did-kill)))
(defun gnus-execute (field regexp form &optional backward ignore-marked)
"If FIELD of article header matches REGEXP, execute lisp FORM (or a string).
If FIELD is an empty string (or nil), entire article body is searched for.
If optional 1st argument BACKWARD is non-nil, do backward instead.
If optional 2nd argument IGNORE-MARKED is non-nil, articles which are
marked as read or ticked are ignored."
(save-excursion
(let ((killed-no 0)
function article header)
(cond
;; Search body.
((or (null field)
(string-equal field ""))
(setq function nil))
;; Get access function of header field.
((fboundp
(setq function
(intern-soft
(concat "mail-header-" (downcase field)))))
(setq function `(lambda (h) (,function h))))
;; Signal error.
(t
(error "Unknown header field: \"%s\"" field)))
;; Starting from the current article.
(while (or
;; First article.
(and (not article)
(setq article (gnus-summary-article-number)))
;; Find later articles.
(setq article
(gnus-summary-search-forward
(not ignore-marked) nil backward)))
(and (or (null gnus-newsgroup-kill-headers)
(memq article gnus-newsgroup-kill-headers))
(vectorp (setq header (gnus-summary-article-header article)))
(gnus-execute-1 function regexp form header)
(setq killed-no (1+ killed-no))))
;; Return the number of killed articles.
killed-no)))
(provide 'gnus-kill)
;;; gnus-kill.el ends here

105
lisp/gnus-mh.el
View file

@ -1,105 +0,0 @@
;;; gnus-mh.el --- mh-e interface for Gnus
;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Send mail using mh-e.
;; The following mh-e interface is all cooperative works of
;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP
;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki
;; SHINGU).
;;; Code:
(require 'mh-e)
(require 'mh-comp)
(require 'gnus)
(require 'gnus-msg)
(eval-when-compile (require 'cl))
(defun gnus-summary-save-article-folder (&optional arg)
"Append the current article to an mh folder.
If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
(interactive "P")
(let ((gnus-default-article-saver 'gnus-summary-save-in-folder))
(gnus-summary-save-article arg)))
(defun gnus-summary-save-in-folder (&optional folder)
"Save this article to MH folder (using `rcvstore' in MH library).
Optional argument FOLDER specifies folder name."
;; Thanks to yuki@flab.Fujitsu.JUNET and ohm@kaba.junet.
(mh-find-path)
(let ((folder
(cond ((and (eq folder 'default)
gnus-newsgroup-last-folder)
gnus-newsgroup-last-folder)
(folder folder)
(t (mh-prompt-for-folder
"Save article in"
(funcall gnus-folder-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-folder)
t))))
(errbuf (get-buffer-create " *Gnus rcvstore*"))
;; Find the rcvstore program.
(exec-path (if mh-lib (cons mh-lib exec-path) exec-path)))
(gnus-eval-in-buffer-window gnus-original-article-buffer
(save-restriction
(widen)
(unwind-protect
(call-process-region
(point-min) (point-max) "rcvstore" nil errbuf nil folder)
(set-buffer errbuf)
(if (zerop (buffer-size))
(message "Article saved in folder: %s" folder)
(message "%s" (buffer-string)))
(kill-buffer errbuf))))
(setq gnus-newsgroup-last-folder folder)))
(defun gnus-Folder-save-name (newsgroup headers &optional last-folder)
"Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
If variable `gnus-use-long-file-name' is nil, it is +News.group.
Otherwise, it is like +news/group."
(or last-folder
(concat "+"
(if gnus-use-long-file-name
(gnus-capitalize-newsgroup newsgroup)
(gnus-newsgroup-directory-form newsgroup)))))
(defun gnus-folder-save-name (newsgroup headers &optional last-folder)
"Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
If variable `gnus-use-long-file-name' is nil, it is +news.group.
Otherwise, it is like +news/group."
(or last-folder
(concat "+"
(if gnus-use-long-file-name
newsgroup
(gnus-newsgroup-directory-form newsgroup)))))
(provide 'gnus-mh)
;;; gnus-mh.el ends here

929
lisp/gnus-msg.el
View file

@ -1,929 +0,0 @@
;;; gnus-msg.el --- mail and post interface for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(require 'gnus-ems)
(require 'message)
(eval-when-compile (require 'cl))
;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
(defvar gnus-post-method nil
"*Preferred method for posting USENET news.
If this variable is nil, Gnus will use the current method to decide
which method to use when posting. If it is non-nil, it will override
the current method. This method will not be used in mail groups and
the like, only in \"real\" newsgroups.
The value must be a valid method as discussed in the documentation of
`gnus-select-method'. It can also be a list of methods. If that is
the case, the user will be queried for what select method to use when
posting.")
(defvar gnus-outgoing-message-group nil
"*All outgoing messages will be put in this group.
If you want to store all your outgoing mail and articles in the group
\"nnml:archive\", you set this variable to that value. This variable
can also be a list of group names.
If you want to have greater control over what group to put each
message in, you can set this variable to a function that checks the
current newsgroup name and then returns a suitable group name (or list
of names).")
(defvar gnus-mailing-list-groups nil
"*Regexp matching groups that are really mailing lists.
This is useful when you're reading a mailing list that has been
gatewayed to a newsgroup, and you want to followup to an article in
the group.")
(defvar gnus-sent-message-ids-file
(nnheader-concat gnus-directory "Sent-Message-IDs")
"File where Gnus saves a cache of sent message ids.")
(defvar gnus-sent-message-ids-length 1000
"The number of sent Message-IDs to save.")
;;; Internal variables.
(defvar gnus-message-buffer "*Mail Gnus*")
(defvar gnus-article-copy nil)
(defvar gnus-last-posting-server nil)
(eval-and-compile
(autoload 'gnus-uu-post-news "gnus-uu" nil t)
(autoload 'news-setup "rnewspost")
(autoload 'news-reply-mode "rnewspost")
(autoload 'rmail-dont-reply-to "mail-utils")
(autoload 'rmail-output "rmailout"))
;;;
;;; Gnus Posting Functions
;;;
(gnus-define-keys
(gnus-summary-send-map "S" gnus-summary-mode-map)
"p" gnus-summary-post-news
"f" gnus-summary-followup
"F" gnus-summary-followup-with-original
"c" gnus-summary-cancel-article
"s" gnus-summary-supersede-article
"r" gnus-summary-reply
"R" gnus-summary-reply-with-original
"m" gnus-summary-mail-other-window
"u" gnus-uu-post-news
"om" gnus-summary-mail-forward
"op" gnus-summary-post-forward
"Om" gnus-uu-digest-mail-forward
"Op" gnus-uu-digest-post-forward)
(gnus-define-keys
(gnus-send-bounce-map "D" gnus-summary-send-map)
"b" gnus-summary-resend-bounced-mail
; "c" gnus-summary-send-draft
"r" gnus-summary-resend-message)
;;; Internal functions.
(defvar gnus-article-reply nil)
(defmacro gnus-setup-message (config &rest forms)
(let ((winconf (make-symbol "winconf"))
(buffer (make-symbol "buffer"))
(article (make-symbol "article")))
`(let ((,winconf (current-window-configuration))
(,buffer (current-buffer))
(,article (and gnus-article-reply (gnus-summary-article-number)))
(message-header-setup-hook
(copy-sequence message-header-setup-hook)))
(add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
(add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
,@forms
(gnus-inews-add-send-actions ,winconf ,buffer ,article)
(setq gnus-message-buffer (current-buffer))
(gnus-configure-windows ,config t))))
(defun gnus-inews-add-send-actions (winconf buffer article)
(gnus-make-local-hook 'message-sent-hook)
(gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
(setq message-post-method
`(lambda (arg)
(gnus-post-method arg ,gnus-newsgroup-name)))
(setq message-newsreader (setq message-mailer (gnus-extended-version)))
(message-add-action
`(set-window-configuration ,winconf) 'exit 'postpone 'kill)
(message-add-action
`(when (buffer-name ,buffer)
(save-excursion
(set-buffer ,buffer)
,(when article
`(gnus-summary-mark-article-as-replied ,article))))
'send))
(put 'gnus-setup-message 'lisp-indent-function 1)
(put 'gnus-setup-message 'lisp-indent-hook 1)
(put 'gnus-setup-message 'edebug-form-spec '(form body))
;;; Post news commands of Gnus group mode and summary mode
(defun gnus-group-mail ()
"Start composing a mail."
(interactive)
(gnus-setup-message 'message
(message-mail)))
(defun gnus-group-post-news (&optional arg)
"Start composing a news message.
If ARG, post to the group under point.
If ARG is 1, prompt for a group name."
(interactive "P")
;; Bind this variable here to make message mode hooks
;; work ok.
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(completing-read "Newsgroup: " gnus-active-hashtb nil
(gnus-read-active-file-p))
(gnus-group-group-name))
"")))
(gnus-post-news 'post gnus-newsgroup-name)))
(defun gnus-summary-post-news ()
"Start composing a news message."
(interactive)
(gnus-set-global-variables)
(gnus-post-news 'post gnus-newsgroup-name))
(defun gnus-summary-followup (yank &optional force-news)
"Compose a followup to an article.
If prefix argument YANK is non-nil, original article is yanked automatically."
(interactive
(list (and current-prefix-arg
(gnus-summary-work-articles 1))))
(gnus-set-global-variables)
(when yank
(gnus-summary-goto-subject (car yank)))
(save-window-excursion
(gnus-summary-select-article))
(let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
(gnus-newsgroup-name gnus-newsgroup-name))
;; Send a followup.
(gnus-post-news nil gnus-newsgroup-name
headers gnus-article-buffer
yank nil force-news)))
(defun gnus-summary-followup-with-original (n &optional force-news)
"Compose a followup to an article and include the original article."
(interactive "P")
(gnus-summary-followup (gnus-summary-work-articles n) force-news))
(defun gnus-inews-yank-articles (articles)
(let (beg article)
(while (setq article (pop articles))
(save-window-excursion
(set-buffer gnus-summary-buffer)
(gnus-summary-select-article nil nil nil article)
(gnus-summary-remove-process-mark article))
(gnus-copy-article-buffer)
(let ((message-reply-buffer gnus-article-copy)
(message-reply-headers gnus-current-headers))
(message-yank-original)
(setq beg (or beg (mark t))))
(when articles (insert "\n")))
(push-mark)
(goto-char beg)))
(defun gnus-summary-cancel-article (n)
"Cancel an article you posted."
(interactive "P")
(gnus-set-global-variables)
(let ((articles (gnus-summary-work-articles n))
(message-post-method
`(lambda (arg)
(gnus-post-method nil ,gnus-newsgroup-name)))
article)
(while (setq article (pop articles))
(when (gnus-summary-select-article t nil nil article)
(when (gnus-eval-in-buffer-window
gnus-original-article-buffer (message-cancel-news))
(gnus-summary-mark-as-read article gnus-canceled-mark)
(gnus-cache-remove-article 1))
(gnus-article-hide-headers-if-wanted))
(gnus-summary-remove-process-mark article))))
(defun gnus-summary-supersede-article ()
"Compose an article that will supersede a previous article.
This is done simply by taking the old article and adding a Supersedes
header line with the old Message-ID."
(interactive)
(gnus-set-global-variables)
(let ((article (gnus-summary-article-number)))
(gnus-setup-message 'reply-yank
(gnus-summary-select-article t)
(set-buffer gnus-original-article-buffer)
(message-supersede)
(push
`((lambda ()
(gnus-cache-possibly-remove-article ,article nil nil nil t)))
message-send-actions))))
(defun gnus-copy-article-buffer (&optional article-buffer)
;; make a copy of the article buffer with all text properties removed
;; this copy is in the buffer gnus-article-copy.
;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
;; this buffer should be passed to all mail/news reply/post routines.
(setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
(buffer-disable-undo gnus-article-copy)
(or (memq gnus-article-copy gnus-buffer-list)
(setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
(let ((article-buffer (or article-buffer gnus-article-buffer))
end beg contents)
(when (and (get-buffer article-buffer)
(buffer-name (get-buffer article-buffer)))
(save-excursion
(set-buffer article-buffer)
(save-restriction
(widen)
(setq contents (format "%s" (buffer-string)))
(set-buffer gnus-original-article-buffer)
(goto-char (point-min))
(while (looking-at message-unix-mail-delimiter)
(forward-line 1))
(setq beg (point))
(setq end (or (search-forward "\n\n" nil t) (point)))
(set-buffer gnus-article-copy)
(erase-buffer)
(insert contents)
(delete-region (goto-char (point-min))
(or (search-forward "\n\n" nil t) (point)))
(insert-buffer-substring gnus-original-article-buffer beg end)))
gnus-article-copy)))
(defun gnus-post-news (post &optional group header article-buffer yank subject
force-news)
(when article-buffer
(gnus-copy-article-buffer))
(let ((gnus-article-reply article-buffer))
(gnus-setup-message (cond (yank 'reply-yank)
(article-buffer 'reply)
(t 'message))
(let* ((group (or group gnus-newsgroup-name))
(pgroup group)
to-address to-group mailing-list to-list)
(when group
(setq to-address (gnus-group-get-parameter group 'to-address)
to-group (gnus-group-get-parameter group 'to-group)
to-list (gnus-group-get-parameter group 'to-list)
mailing-list (when gnus-mailing-list-groups
(string-match gnus-mailing-list-groups group))
group (gnus-group-real-name group)))
(if (or (and to-group
(gnus-news-group-p to-group))
force-news
(and (gnus-news-group-p
(or pgroup gnus-newsgroup-name)
(if header (mail-header-number header)
gnus-current-article))
(not mailing-list)
(not to-list)
(not to-address)))
;; This is news.
(if post
(message-news (or to-group group))
(set-buffer gnus-article-copy)
(message-followup))
;; The is mail.
(if post
(progn
(message-mail (or to-address to-list))
;; Arrange for mail groups that have no `to-address' to
;; get that when the user sends off the mail.
(push (list 'gnus-inews-add-to-address group)
message-send-actions))
(set-buffer gnus-article-copy)
(message-wide-reply to-address)))
(when yank
(gnus-inews-yank-articles yank))))))
(defun gnus-post-method (arg group &optional silent)
"Return the posting method based on GROUP and ARG.
If SILENT, don't prompt the user."
(let ((group-method (gnus-find-method-for-group group)))
(cond
;; If the group-method is nil (which shouldn't happen) we use
;; the default method.
((null arg)
(or gnus-post-method gnus-select-method message-post-method))
;; We want this group's method.
((and arg (not (eq arg 0)))
group-method)
;; We query the user for a post method.
((or arg
(and gnus-post-method
(listp (car gnus-post-method))))
(let* ((methods
;; Collect all methods we know about.
(append
(when gnus-post-method
(if (listp (car gnus-post-method))
gnus-post-method
(list gnus-post-method)))
gnus-secondary-select-methods
(list gnus-select-method)
(list group-method)))
method-alist post-methods method)
;; Weed out all mail methods.
(while methods
(setq method (gnus-server-get-method "" (pop methods)))
(when (or (gnus-method-option-p method 'post)
(gnus-method-option-p method 'post-mail))
(push method post-methods)))
;; Create a name-method alist.
(setq method-alist
(mapcar
(lambda (m)
(list (concat (cadr m) " (" (symbol-name (car m)) ")") m))
post-methods))
;; Query the user.
(cadr
(assoc
(setq gnus-last-posting-server
(if (and silent
gnus-last-posting-server)
;; Just use the last value.
gnus-last-posting-server
(completing-read
"Posting method: " method-alist nil t
(cons (or gnus-last-posting-server "") 0))))
method-alist))))
;; Override normal method.
((and gnus-post-method
(or (gnus-method-option-p group-method 'post)
(gnus-method-option-p group-method 'post-mail)))
gnus-post-method)
;; Perhaps this is a mail group?
((and (not (gnus-member-of-valid 'post group))
(not (gnus-method-option-p group-method 'post-mail)))
group-method)
;; Use the normal select method.
(t gnus-select-method))))
(defun gnus-inews-narrow-to-headers ()
(widen)
(narrow-to-region
(goto-char (point-min))
(or (and (re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$") nil t)
(match-beginning 0))
(point-max)))
(goto-char (point-min)))
;;;
;;; Check whether the message has been sent already.
;;;
(defvar gnus-inews-sent-ids nil)
(defun gnus-inews-reject-message ()
"Check whether this message has already been sent."
(when gnus-sent-message-ids-file
(let ((message-id (save-restriction (gnus-inews-narrow-to-headers)
(mail-fetch-field "message-id")))
end)
(when message-id
(unless gnus-inews-sent-ids
(condition-case ()
(load t t t)
(error nil)))
(if (member message-id gnus-inews-sent-ids)
;; Reject this message.
(not (gnus-yes-or-no-p
(format "Message %s already sent. Send anyway? "
message-id)))
(push message-id gnus-inews-sent-ids)
;; Chop off the last Message-IDs.
(when (setq end (nthcdr gnus-sent-message-ids-length
gnus-inews-sent-ids))
(setcdr end nil))
(nnheader-temp-write gnus-sent-message-ids-file
(prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids)
(current-buffer)))
nil)))))
;; Dummy to avoid byte-compile warning.
(defvar nnspool-rejected-article-hook)
;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
;;; as well include the Emacs version as well.
;;; The following function works with later GNU Emacs, and XEmacs.
(defun gnus-extended-version ()
"Stringified Gnus version and Emacs version"
(interactive)
(concat
gnus-version
"/"
(cond
((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version)
(concat "Emacs " (substring emacs-version
(match-beginning 1)
(match-end 1))))
((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)" emacs-version)
(concat (substring emacs-version
(match-beginning 1)
(match-end 1))
(format " %d.%d" emacs-major-version emacs-minor-version)))
(t emacs-version))))
;; Written by "Mr. Per Persson" <pp@solace.mh.se>.
(defun gnus-inews-insert-mime-headers ()
(goto-char (point-min))
(let ((mail-header-separator
(progn
(goto-char (point-min))
(if (and (search-forward (concat "\n" mail-header-separator "\n")
nil t)
(not (search-backward "\n\n" nil t)))
mail-header-separator
""))))
(or (mail-position-on-field "Mime-Version")
(insert "1.0")
(cond ((save-restriction
(widen)
(goto-char (point-min))
(re-search-forward "[\200-\377]" nil t))
(or (mail-position-on-field "Content-Type")
(insert "text/plain; charset=ISO-8859-1"))
(or (mail-position-on-field "Content-Transfer-Encoding")
(insert "8bit")))
(t (or (mail-position-on-field "Content-Type")
(insert "text/plain; charset=US-ASCII"))
(or (mail-position-on-field "Content-Transfer-Encoding")
(insert "7bit")))))))
;;;
;;; Gnus Mail Functions
;;;
;;; Mail reply commands of Gnus summary mode
(defun gnus-summary-reply (&optional yank)
"Reply mail to news author.
If prefix argument YANK is non-nil, original article is yanked automatically."
(interactive
(list (and current-prefix-arg
(gnus-summary-work-articles 1))))
;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
;; Stripping headers should be specified with mail-yank-ignored-headers.
(gnus-set-global-variables)
(when yank
(gnus-summary-goto-subject (car yank)))
(let ((gnus-article-reply t))
(gnus-setup-message (if yank 'reply-yank 'reply)
(gnus-summary-select-article)
(set-buffer (gnus-copy-article-buffer))
(message-reply nil nil (gnus-group-get-parameter
gnus-newsgroup-name 'broken-reply-to))
(when yank
(gnus-inews-yank-articles yank)))))
(defun gnus-summary-reply-with-original (n)
"Reply mail to news author with original article."
(interactive "P")
(gnus-summary-reply (gnus-summary-work-articles n)))
(defun gnus-summary-mail-forward (&optional post)
"Forward the current message to another user."
(interactive "P")
(gnus-set-global-variables)
(gnus-setup-message 'forward
(gnus-summary-select-article)
(set-buffer gnus-original-article-buffer)
(message-forward post)))
(defun gnus-summary-resend-message (address)
"Resend the current article to ADDRESS."
(interactive "sResend message to: ")
(gnus-summary-select-article)
(save-excursion
(set-buffer gnus-original-article-buffer)
(message-resend address)))
(defun gnus-summary-post-forward ()
"Forward the current article to a newsgroup."
(interactive)
(gnus-summary-mail-forward t))
(defvar gnus-nastygram-message
"The following article was inappropriately posted to %s.\n"
"Format string to insert in nastygrams.
The current group name will be inserted at \"%s\".")
(defun gnus-summary-mail-nastygram (n)
"Send a nastygram to the author of the current article."
(interactive "P")
(if (or gnus-expert-user
(gnus-y-or-n-p
"Really send a nastygram to the author of the current article? "))
(let ((group gnus-newsgroup-name))
(gnus-summary-reply-with-original n)
(set-buffer gnus-message-buffer)
(insert (format gnus-nastygram-message group))
(message-send-and-exit))))
(defun gnus-summary-mail-other-window ()
"Compose mail in other window."
(interactive)
(gnus-setup-message 'message
(message-mail)))
(defun gnus-mail-parse-comma-list ()
(let (accumulated
beg)
(skip-chars-forward " ")
(while (not (eobp))
(setq beg (point))
(skip-chars-forward "^,")
(while (zerop
(save-excursion
(save-restriction
(let ((i 0))
(narrow-to-region beg (point))
(goto-char beg)
(logand (progn
(while (search-forward "\"" nil t)
(incf i))
(if (zerop i) 2 i)) 2)))))
(skip-chars-forward ",")
(skip-chars-forward "^,"))
(skip-chars-backward " ")
(setq accumulated
(cons (buffer-substring beg (point))
accumulated))
(skip-chars-forward "^,")
(skip-chars-forward ", "))
accumulated))
(defun gnus-mail-yank-original ()
(interactive)
(save-excursion
(mail-yank-original nil))
(or mail-yank-hooks mail-citation-hook
(run-hooks 'news-reply-header-hook)))
(defun gnus-inews-add-to-address (group)
(let ((to-address (mail-fetch-field "to")))
(when (and to-address
(gnus-alive-p))
;; This mail group doesn't have a `to-list', so we add one
;; here. Magic!
(gnus-group-add-parameter group (cons 'to-list to-address)))))
(defun gnus-put-message ()
"Put the current message in some group and return to Gnus."
(interactive)
(let ((reply gnus-article-reply)
(winconf gnus-prev-winconf)
(group gnus-newsgroup-name))
(or (and group (not (gnus-group-read-only-p group)))
(setq group (read-string "Put in group: " nil
(gnus-writable-groups))))
(and (gnus-gethash group gnus-newsrc-hashtb)
(error "No such group: %s" group))
(save-excursion
(save-restriction
(widen)
(gnus-inews-narrow-to-headers)
(let (gnus-deletable-headers)
(if (message-news-p)
(message-generate-headers message-required-news-headers)
(message-generate-headers message-required-mail-headers)))
(goto-char (point-max))
(insert "Gcc: " group "\n")
(widen)))
(gnus-inews-do-gcc)
(if (get-buffer gnus-group-buffer)
(progn
(if (gnus-buffer-exists-p (car-safe reply))
(progn
(set-buffer (car reply))
(and (cdr reply)
(gnus-summary-mark-article-as-replied
(cdr reply)))))
(and winconf (set-window-configuration winconf))))))
(defun gnus-article-mail (yank)
"Send a reply to the address near point.
If YANK is non-nil, include the original article."
(interactive "P")
(let ((address
(buffer-substring
(save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
(save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
(when address
(message-reply address)
(when yank
(gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
(defun gnus-bug ()
"Send a bug report to the Gnus maintainers."
(interactive)
(gnus-setup-message 'bug
(delete-other-windows)
(switch-to-buffer "*Gnus Help Bug*")
(erase-buffer)
(insert gnus-bug-message)
(goto-char (point-min))
(message-pop-to-buffer "*Gnus Bug*")
(message-setup `((To . ,gnus-maintainer) (Subject . "")))
(push `(gnus-bug-kill-buffer) message-send-actions)
(goto-char (point-min))
(re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
(forward-line 1)
(insert (gnus-version) "\n")
(insert (emacs-version))
(insert "\n\n\n\n\n")
(gnus-debug)
(goto-char (point-min))
(search-forward "Subject: " nil t)
(message "")))
(defun gnus-bug-kill-buffer ()
(and (get-buffer "*Gnus Help Bug*")
(kill-buffer "*Gnus Help Bug*")))
(defun gnus-debug ()
"Attemps to go through the Gnus source file and report what variables have been changed.
The source file has to be in the Emacs load path."
(interactive)
(let ((files '("gnus.el" "gnus-msg.el" "gnus-score.el" "nnmail.el"
"message.el"))
file dirs expr olist sym)
(gnus-message 4 "Please wait while we snoop your variables...")
(sit-for 0)
(save-excursion
(set-buffer (get-buffer-create " *gnus bug info*"))
(buffer-disable-undo (current-buffer))
(while files
(erase-buffer)
(setq dirs load-path)
(while dirs
(if (or (not (car dirs))
(not (stringp (car dirs)))
(not (file-exists-p
(setq file (concat (file-name-as-directory
(car dirs)) (car files))))))
(setq dirs (cdr dirs))
(setq dirs nil)
(insert-file-contents file)
(goto-char (point-min))
(if (not (re-search-forward "^;;* *Internal variables" nil t))
(gnus-message 4 "Malformed sources in file %s" file)
(narrow-to-region (point-min) (point))
(goto-char (point-min))
(while (setq expr (condition-case ()
(read (current-buffer)) (error nil)))
(condition-case ()
(and (eq (car expr) 'defvar)
(stringp (nth 3 expr))
(or (not (boundp (nth 1 expr)))
(not (equal (eval (nth 2 expr))
(symbol-value (nth 1 expr)))))
(setq olist (cons (nth 1 expr) olist)))
(error nil))))))
(setq files (cdr files)))
(kill-buffer (current-buffer)))
(when (setq olist (nreverse olist))
(insert "------------------ Environment follows ------------------\n\n"))
(while olist
(if (boundp (car olist))
(condition-case ()
(pp `(setq ,(car olist)
,(if (or (consp (setq sym (symbol-value (car olist))))
(and (symbolp sym)
(not (or (eq sym nil)
(eq sym t)))))
(list 'quote (symbol-value (car olist)))
(symbol-value (car olist))))
(current-buffer))
(error
(format "(setq %s 'whatever)\n" (car olist))))
(insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
(setq olist (cdr olist)))
(insert "\n\n")
;; Remove any null chars - they seem to cause trouble for some
;; mailers. (Byte-compiled output from the stuff above.)
(goto-char (point-min))
(while (re-search-forward "[\000\200]" nil t)
(replace-match "" t t))))
;;; Treatment of rejected articles.
;;; Bounced mail.
(defun gnus-summary-resend-bounced-mail (&optional fetch)
"Re-mail the current message.
This only makes sense if the current message is a bounce message than
contains some mail you have written which has been bounced back to
you.
If FETCH, try to fetch the article that this is a reply to, if indeed
this is a reply."
(interactive "P")
(gnus-summary-select-article t)
(set-buffer gnus-original-article-buffer)
(gnus-setup-message 'compose-bounce
(let* ((references (mail-fetch-field "references"))
(parent (and references (gnus-parent-id references))))
(message-bounce)
;; If there are references, we fetch the article we answered to.
(and fetch parent
(gnus-summary-refer-article parent)
(gnus-summary-show-all-headers)))))
;;; Gcc handling.
;; Do Gcc handling, which copied the message over to some group.
(defun gnus-inews-do-gcc (&optional gcc)
(when (gnus-alive-p)
(save-excursion
(save-restriction
(message-narrow-to-headers)
(let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
(cur (current-buffer))
groups group method)
(when gcc
(message-remove-header "gcc")
(widen)
(setq groups (message-tokenize-header gcc " ,"))
;; Copy the article over to some group(s).
(while (setq group (pop groups))
(gnus-check-server
(setq method
(cond ((and (null (gnus-get-info group))
(eq (car gnus-message-archive-method)
(car
(gnus-server-to-method
(gnus-group-method group)))))
;; If the group doesn't exist, we assume
;; it's an archive group...
gnus-message-archive-method)
;; Use the method.
((gnus-info-method (gnus-get-info group))
(gnus-info-method (gnus-get-info group)))
;; Find the method.
(t (gnus-group-method group)))))
(gnus-check-server method)
(unless (gnus-request-group group t method)
(gnus-request-create-group group method))
(save-excursion
(nnheader-set-temp-buffer " *acc*")
(insert-buffer-substring cur)
(goto-char (point-min))
(when (re-search-forward
(concat "^" (regexp-quote mail-header-separator) "$")
nil t)
(replace-match "" t t ))
(unless (gnus-request-accept-article group method t)
(gnus-message 1 "Couldn't store article in group %s: %s"
group (gnus-status-message method))
(sit-for 2))
(kill-buffer (current-buffer))))))))))
(defun gnus-inews-insert-gcc ()
"Insert Gcc headers based on `gnus-outgoing-message-group'."
(save-excursion
(save-restriction
(gnus-inews-narrow-to-headers)
(let* ((group gnus-outgoing-message-group)
(gcc (cond
((gnus-functionp group)
(funcall group))
((or (stringp group) (list group))
group))))
(when gcc
(insert "Gcc: "
(if (stringp gcc) gcc
(mapconcat 'identity gcc " "))
"\n"))))))
(defun gnus-inews-insert-archive-gcc (&optional group)
"Insert the Gcc to say where the article is to be archived."
(let* ((var gnus-message-archive-group)
(group (or group gnus-newsgroup-name ""))
result
(groups
(cond
((null gnus-message-archive-method)
;; Ignore.
nil)
((stringp var)
;; Just a single group.
(list var))
((null var)
;; We don't want this.
nil)
((and (listp var) (stringp (car var)))
;; A list of groups.
var)
((gnus-functionp var)
;; A function.
(funcall var group))
(t
;; An alist of regexps/functions/forms.
(while (and var
(not
(setq result
(cond
((stringp (caar var))
;; Regexp.
(when (string-match (caar var) group)
(cdar var)))
((gnus-functionp (car var))
;; Function.
(funcall (car var) group))
(t
(eval (car var)))))))
(setq var (cdr var)))
result)))
name)
(when groups
(when (stringp groups)
(setq groups (list groups)))
(save-excursion
(save-restriction
(gnus-inews-narrow-to-headers)
(goto-char (point-max))
(insert "Gcc: ")
(while (setq name (pop groups))
(insert (if (string-match ":" name)
name
(gnus-group-prefixed-name
name gnus-message-archive-method)))
(if groups (insert " ")))
(insert "\n"))))))
(defun gnus-summary-send-draft ()
"Enter a mail/post buffer to edit and send the draft."
(interactive)
(gnus-set-global-variables)
(let (buf)
(if (not (setq buf (gnus-request-restore-buffer
(gnus-summary-article-number) gnus-newsgroup-name)))
(error "Couldn't restore the article")
(switch-to-buffer buf)
(when (eq major-mode 'news-reply-mode)
(local-set-key "\C-c\C-c" 'gnus-inews-news))
;; Insert the separator.
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(insert mail-header-separator)
;; Configure windows.
(let ((gnus-draft-buffer (current-buffer)))
(gnus-configure-windows 'draft t)
(goto-char (point))))))
(gnus-add-shutdown 'gnus-inews-close 'gnus)
(defun gnus-inews-close ()
(setq gnus-inews-sent-ids nil))
;;; Allow redefinition of functions.
(gnus-ems-redefine)
(provide 'gnus-msg)
;;; gnus-msg.el ends here

247
lisp/gnus-nocem.el
View file

@ -1,247 +0,0 @@
;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(require 'nnmail)
(eval-when-compile (require 'cl))
(defvar gnus-nocem-groups
'("alt.nocem.misc" "news.admin.net-abuse.announce")
"*List of groups that will be searched for NoCeM messages.")
(defvar gnus-nocem-issuers
'("Automoose-1" ; The CancelMoose[tm] on autopilot.
"clewis@ferret.ocunix.on.ca;" ; Chris Lewis -- Canadian angel & despammer.
"jem@xpat.com;" ; John Milburn -- despammer in Korea.
"red@redpoll.mrfs.oh.us (Richard E. Depew)" ; Spew/bincancel guy.
)
"*List of NoCeM issuers to pay attention to.")
(defvar gnus-nocem-directory
(concat (file-name-as-directory gnus-article-save-directory) "NoCeM/")
"*Directory where NoCeM files will be stored.")
(defvar gnus-nocem-expiry-wait 15
"*Number of days to keep NoCeM headers in the cache.")
(defvar gnus-nocem-verifyer nil
"*Function called to verify that the NoCeM message is valid.
One likely value is `mc-verify'. If the function in this variable
isn't bound, the message will be used unconditionally.")
;;; Internal variables
(defvar gnus-nocem-active nil)
(defvar gnus-nocem-alist nil)
(defvar gnus-nocem-touched-alist nil)
(defvar gnus-nocem-hashtb nil)
;;; Functions
(defun gnus-nocem-active-file ()
(concat (file-name-as-directory gnus-nocem-directory) "active"))
(defun gnus-nocem-cache-file ()
(concat (file-name-as-directory gnus-nocem-directory) "cache"))
(defun gnus-nocem-scan-groups ()
"Scan all NoCeM groups for new NoCeM messages."
(interactive)
(let ((groups gnus-nocem-groups)
group active gactive articles)
(or (file-exists-p gnus-nocem-directory)
(make-directory gnus-nocem-directory t))
;; Load any previous NoCeM headers.
(gnus-nocem-load-cache)
;; Read the active file if it hasn't been read yet.
(and (file-exists-p (gnus-nocem-active-file))
(not gnus-nocem-active)
(condition-case ()
(load (gnus-nocem-active-file) t t t)
(error nil)))
;; Go through all groups and see whether new articles have
;; arrived.
(while (setq group (pop groups))
(if (not (setq gactive (gnus-activate-group group)))
() ; This group doesn't exist.
(setq active (nth 1 (assoc group gnus-nocem-active)))
(when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
(or (not active)
(< (cdr active) (cdr gactive))))
;; Ok, there are new articles in this group, se we fetch the
;; headers.
(save-excursion
(let ((dependencies (make-vector 10 nil))
(buffer (nnheader-set-temp-buffer " *Gnus NoCeM*"))
headers)
(setq headers
(if (eq 'nov
(gnus-retrieve-headers
(setq articles
(gnus-uncompress-range
(cons
(if active (1+ (cdr active))
(car gactive))
(cdr gactive))))
group))
(gnus-get-newsgroup-headers-xover
articles nil dependencies)
(gnus-get-newsgroup-headers dependencies)))
(while headers
;; We take a closer look on all articles that have
;; "@@NCM" in the subject.
(when (string-match "@@NCM"
(mail-header-subject (car headers)))
(gnus-nocem-check-article group (car headers)))
(setq headers (cdr headers)))
(kill-buffer (current-buffer)))))
(setq gnus-nocem-active
(cons (list group gactive)
(delq (assoc group gnus-nocem-active)
gnus-nocem-active)))))
;; Save the results, if any.
(gnus-nocem-save-cache)
(gnus-nocem-save-active)))
(defun gnus-nocem-check-article (group header)
"Check whether the current article is an NCM article and that we want it."
;; Get the article.
(gnus-message 7 "Checking article %d in %s for NoCeM..."
(mail-header-number header) group)
(let ((date (mail-header-date header))
issuer b e)
(when (or (not date)
(nnmail-time-less
(nnmail-time-since (nnmail-date-to-time date))
(nnmail-days-to-time gnus-nocem-expiry-wait)))
(gnus-request-article-this-buffer (mail-header-number header) group)
(goto-char (point-min))
;; The article has to have proper NoCeM headers.
(when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
(setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
;; We get the name of the issuer.
(narrow-to-region b e)
(setq issuer (mail-fetch-field "issuer"))
(and (member issuer gnus-nocem-issuers) ; We like her...
(gnus-nocem-verify-issuer issuer) ; She is who she says she is..
(gnus-nocem-enter-article)))))) ; We gobble the message.
(defun gnus-nocem-verify-issuer (person)
"Verify using PGP that the canceler is who she says she is."
(widen)
(if (fboundp gnus-nocem-verifyer)
(funcall gnus-nocem-verifyer)
;; If we don't have MailCrypt, then we use the message anyway.
t))
(defun gnus-nocem-enter-article ()
"Enter the current article into the NoCeM cache."
(goto-char (point-min))
(let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
(e (search-forward "\n@@END NCM BODY\n" nil t))
(buf (current-buffer))
ncm id)
(when (and b e)
(narrow-to-region b (1+ (match-beginning 0)))
(goto-char (point-min))
(while (search-forward "\t" nil t)
(when (condition-case nil
(boundp (let ((obarray gnus-active-hashtb)) (read buf)))
(error nil))
(beginning-of-line)
(while (= (following-char) ?\t)
(forward-line -1))
(setq id (buffer-substring (point) (1- (search-forward "\t"))))
(push id ncm)
(gnus-sethash id t gnus-nocem-hashtb)
(forward-line 1)
(while (= (following-char) ?\t)
(forward-line 1))))
(when ncm
(setq gnus-nocem-touched-alist t)
(push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
ncm)
gnus-nocem-alist)))))
(defun gnus-nocem-load-cache ()
"Load the NoCeM cache."
(unless gnus-nocem-alist
;; The buffer doesn't exist, so we create it and load the NoCeM
;; cache.
(when (file-exists-p (gnus-nocem-cache-file))
(load (gnus-nocem-cache-file) t t t)
(gnus-nocem-alist-to-hashtb))))
(defun gnus-nocem-save-cache ()
"Save the NoCeM cache."
(when (and gnus-nocem-alist
gnus-nocem-touched-alist)
(nnheader-temp-write (gnus-nocem-cache-file)
(prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist) (current-buffer)))
(setq gnus-nocem-touched-alist nil)))
(defun gnus-nocem-save-active ()
"Save the NoCeM active file."
(nnheader-temp-write (gnus-nocem-active-file)
(prin1 `(setq gnus-nocem-active ',gnus-nocem-active) (current-buffer))))
(defun gnus-nocem-alist-to-hashtb ()
"Create a hashtable from the Message-IDs we have."
(let* ((alist gnus-nocem-alist)
(pprev (cons nil alist))
(prev pprev)
(expiry (nnmail-days-to-time gnus-nocem-expiry-wait))
entry)
(setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51)))
(while (setq entry (car alist))
(if (not (nnmail-time-less (nnmail-time-since (car entry)) expiry))
;; This entry has expired, so we remove it.
(setcdr prev (cdr alist))
(setq prev alist)
;; This is ok, so we enter it into the hashtable.
(setq entry (cdr entry))
(while entry
(gnus-sethash (car entry) t gnus-nocem-hashtb)
(setq entry (cdr entry))))
(setq alist (cdr alist)))))
(gnus-add-shutdown 'gnus-nocem-close 'gnus)
(defun gnus-nocem-close ()
"Clear internal NoCeM variables."
(setq gnus-nocem-alist nil
gnus-nocem-hashtb nil
gnus-nocem-active nil
gnus-nocem-touched-alist nil))
(defun gnus-nocem-unwanted-article-p (id)
"Say whether article ID in the current group is wanted."
(gnus-gethash id gnus-nocem-hashtb))
(provide 'gnus-nocem)
;;; gnus-nocem.el ends here

654
lisp/gnus-salt.el
View file

@ -1,654 +0,0 @@
;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
;;;
;;; gnus-pick-mode
;;;
(defvar gnus-pick-mode nil
"Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
(defvar gnus-pick-display-summary nil
"*Display summary while reading.")
(defvar gnus-pick-mode-hook nil
"Hook run in summary pick mode buffers.")
;;; Internal variables.
(defvar gnus-pick-mode-map nil)
(unless gnus-pick-mode-map
(setq gnus-pick-mode-map (make-sparse-keymap))
(gnus-define-keys
gnus-pick-mode-map
"t" gnus-uu-mark-thread
"T" gnus-uu-unmark-thread
" " gnus-summary-mark-as-processable
"u" gnus-summary-unmark-as-processable
"U" gnus-summary-unmark-all-processable
"v" gnus-uu-mark-over
"r" gnus-uu-mark-region
"R" gnus-uu-unmark-region
"e" gnus-uu-mark-by-regexp
"E" gnus-uu-mark-by-regexp
"b" gnus-uu-mark-buffer
"B" gnus-uu-unmark-buffer
"\r" gnus-pick-start-reading))
(defun gnus-pick-make-menu-bar ()
(unless (boundp 'gnus-pick-menu)
(easy-menu-define
gnus-pick-menu gnus-pick-mode-map ""
'("Pick"
("Pick"
["Article" gnus-summary-mark-as-processable t]
["Thread" gnus-uu-mark-thread t]
["Region" gnus-uu-mark-region t]
["Regexp" gnus-uu-mark-regexp t]
["Buffer" gnus-uu-mark-buffer t])
("Unpick"
["Article" gnus-summary-unmark-as-processable t]
["Thread" gnus-uu-unmark-thread t]
["Region" gnus-uu-unmark-region t]
["Regexp" gnus-uu-unmark-regexp t]
["Buffer" gnus-uu-unmark-buffer t])
["Start reading" gnus-pick-start-reading t]
["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
(defun gnus-pick-mode (&optional arg)
"Minor mode for providing a pick-and-read interface in Gnus summary buffers.
\\{gnus-pick-mode-map}"
(interactive "P")
(when (eq major-mode 'gnus-summary-mode)
(make-local-variable 'gnus-pick-mode)
(setq gnus-pick-mode
(if (null arg) (not gnus-pick-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-pick-mode
;; Make sure that we don't select any articles upon group entry.
(make-local-variable 'gnus-auto-select-first)
(setq gnus-auto-select-first nil)
;; Set up the menu.
(when (and menu-bar-mode
(gnus-visual-p 'pick-menu 'menu))
(gnus-pick-make-menu-bar))
(unless (assq 'gnus-pick-mode minor-mode-alist)
(push '(gnus-pick-mode " Pick") minor-mode-alist))
(unless (assq 'gnus-pick-mode minor-mode-map-alist)
(push (cons 'gnus-pick-mode gnus-pick-mode-map)
minor-mode-map-alist))
(run-hooks 'gnus-pick-mode-hook))))
(defun gnus-pick-start-reading (&optional catch-up)
"Start reading the picked articles.
If given a prefix, mark all unpicked articles as read."
(interactive "P")
(unless gnus-newsgroup-processable
(error "No articles have been picked"))
(gnus-summary-limit-to-articles nil)
(when catch-up
(gnus-summary-limit-mark-excluded-as-read))
(gnus-summary-first-unread-article)
(gnus-configure-windows (if gnus-pick-display-summary 'article 'pick) t))
;;;
;;; gnus-binary-mode
;;;
(defvar gnus-binary-mode nil
"Minor mode for provind a binary group interface in Gnus summary buffers.")
(defvar gnus-binary-mode-hook nil
"Hook run in summary binary mode buffers.")
(defvar gnus-binary-mode-map nil)
(unless gnus-binary-mode-map
(setq gnus-binary-mode-map (make-sparse-keymap))
(gnus-define-keys
gnus-binary-mode-map
"g" gnus-binary-show-article))
(defun gnus-binary-make-menu-bar ()
(unless (boundp 'gnus-binary-menu)
(easy-menu-define
gnus-binary-menu gnus-binary-mode-map ""
'("Pick"
["Switch binary mode off" gnus-binary-mode t]))))
(defun gnus-binary-mode (&optional arg)
"Minor mode for providing a binary group interface in Gnus summary buffers."
(interactive "P")
(when (eq major-mode 'gnus-summary-mode)
(make-local-variable 'gnus-binary-mode)
(setq gnus-binary-mode
(if (null arg) (not gnus-binary-mode)
(> (prefix-numeric-value arg) 0)))
(when gnus-binary-mode
;; Make sure that we don't select any articles upon group entry.
(make-local-variable 'gnus-auto-select-first)
(setq gnus-auto-select-first nil)
(make-local-variable 'gnus-summary-display-article-function)
(setq gnus-summary-display-article-function 'gnus-binary-display-article)
;; Set up the menu.
(when (and menu-bar-mode
(gnus-visual-p 'binary-menu 'menu))
(gnus-binary-make-menu-bar))
(unless (assq 'gnus-binary-mode minor-mode-alist)
(push '(gnus-binary-mode " Binary") minor-mode-alist))
(unless (assq 'gnus-binary-mode minor-mode-map-alist)
(push (cons 'gnus-binary-mode gnus-binary-mode-map)
minor-mode-map-alist))
(run-hooks 'gnus-binary-mode-hook))))
(defun gnus-binary-display-article (article &optional all-header)
"Run ARTICLE through the binary decode functions."
(when (gnus-summary-goto-subject article)
(let ((gnus-view-pseudos 'automatic))
(gnus-uu-decode-uu))))
(defun gnus-binary-show-article (&optional arg)
"Bypass the binary functions and show the article."
(interactive "P")
(let (gnus-summary-display-article-function)
(gnus-summary-show-article arg)))
;;;
;;; gnus-tree-mode
;;;
(defvar gnus-tree-line-format "%(%[%3,3n%]%)"
"Format of tree elements.")
(defvar gnus-tree-minimize-window t
"If non-nil, minimize the tree buffer window.
If a number, never let the tree buffer grow taller than that number of
lines.")
(defvar gnus-selected-tree-face 'modeline
"*Face used for highlighting selected articles in the thread tree.")
(defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
(?\{ . ?\}) (?< . ?>))
"Brackets used in tree nodes.")
(defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
"Charaters used to connect parents with children.")
(defvar gnus-tree-mode-line-format "Gnus: %%b %S %Z"
"*The format specification for the tree mode line.")
(defvar gnus-generate-tree-function 'gnus-generate-vertical-tree
"*Function for generating a thread tree.
Two predefined functions are available:
`gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'.")
(defvar gnus-tree-mode-hook nil
"*Hook run in tree mode buffers.")
;;; Internal variables.
(defvar gnus-tree-line-format-alist
`((?n gnus-tmp-name ?s)
(?f gnus-tmp-from ?s)
(?N gnus-tmp-number ?d)
(?\[ gnus-tmp-open-bracket ?c)
(?\] gnus-tmp-close-bracket ?c)
(?s gnus-tmp-subject ?s)))
(defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist)
(defvar gnus-tree-mode-line-format-spec nil)
(defvar gnus-tree-line-format-spec nil)
(defvar gnus-tree-node-length nil)
(defvar gnus-selected-tree-overlay nil)
(defvar gnus-tree-displayed-thread nil)
(defvar gnus-tree-mode-map nil)
(put 'gnus-tree-mode 'mode-class 'special)
(unless gnus-tree-mode-map
(setq gnus-tree-mode-map (make-keymap))
(suppress-keymap gnus-tree-mode-map)
(gnus-define-keys
gnus-tree-mode-map
"\r" gnus-tree-select-article
gnus-mouse-2 gnus-tree-pick-article
"\C-?" gnus-tree-read-summary-keys
"\C-c\C-i" gnus-info-find-node)
(substitute-key-definition
'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
(defun gnus-tree-make-menu-bar ()
(unless (boundp 'gnus-tree-menu)
(easy-menu-define
gnus-tree-menu gnus-tree-mode-map ""
'("Tree"
["Select article" gnus-tree-select-article t]))))
(defun gnus-tree-mode ()
"Major mode for displaying thread trees."
(interactive)
(setq gnus-tree-mode-line-format-spec
(gnus-parse-format gnus-tree-mode-line-format
gnus-summary-mode-line-format-alist))
(setq gnus-tree-line-format-spec
(gnus-parse-format gnus-tree-line-format
gnus-tree-line-format-alist t))
(when (and menu-bar-mode
(gnus-visual-p 'tree-menu 'menu))
(gnus-tree-make-menu-bar))
(kill-all-local-variables)
(gnus-simplify-mode-line)
(setq mode-name "Tree")
(setq major-mode 'gnus-tree-mode)
(use-local-map gnus-tree-mode-map)
(buffer-disable-undo (current-buffer))
(setq buffer-read-only t)
(setq truncate-lines t)
(save-excursion
(gnus-set-work-buffer)
(gnus-tree-node-insert (make-mail-header "") nil)
(setq gnus-tree-node-length (1- (point))))
(run-hooks 'gnus-tree-mode-hook))
(defun gnus-tree-read-summary-keys (&optional arg)
"Read a summary buffer key sequence and execute it."
(interactive "P")
(let ((buf (current-buffer))
win)
(gnus-article-read-summary-keys arg nil t)
(when (setq win (get-buffer-window buf))
(select-window win)
(when gnus-selected-tree-overlay
(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
(gnus-tree-minimize))))
(defun gnus-tree-select-article (article)
"Select the article under point, if any."
(interactive (list (gnus-tree-article-number)))
(let ((buf (current-buffer)))
(when article
(save-excursion
(set-buffer gnus-summary-buffer)
(gnus-summary-goto-article article))
(select-window (get-buffer-window buf)))))
(defun gnus-tree-pick-article (e)
"Select the article under the mouse pointer."
(interactive "e")
(mouse-set-point e)
(gnus-tree-select-article (gnus-tree-article-number)))
(defun gnus-tree-article-number ()
(get-text-property (point) 'gnus-number))
(defun gnus-tree-article-region (article)
"Return a cons with BEG and END of the article region."
(let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
(when pos
(cons pos (next-single-property-change pos 'gnus-number)))))
(defun gnus-tree-goto-article (article)
(let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
(when pos
(goto-char pos))))
(defun gnus-tree-recenter ()
"Center point in the tree window."
(let ((selected (selected-window))
(tree-window (get-buffer-window gnus-tree-buffer t)))
(when tree-window
(select-window tree-window)
(when gnus-selected-tree-overlay
(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
(let* ((top (cond ((< (window-height) 4) 0)
((< (window-height) 7) 1)
(t 2)))
(height (1- (window-height)))
(bottom (save-excursion (goto-char (point-max))
(forward-line (- height))
(point))))
;; Set the window start to either `bottom', which is the biggest
;; possible valid number, or the second line from the top,
;; whichever is the least.
(set-window-start
tree-window (min bottom (save-excursion
(forward-line (- top)) (point)))))
(select-window selected))))
(defun gnus-get-tree-buffer ()
"Return the tree buffer properly initialized."
(save-excursion
(set-buffer (get-buffer-create gnus-tree-buffer))
(unless (eq major-mode 'gnus-tree-mode)
(gnus-add-current-to-buffer-list)
(gnus-tree-mode))
(current-buffer)))
(defun gnus-tree-minimize ()
(when (and gnus-tree-minimize-window
(not (one-window-p)))
(let ((windows 0)
tot-win-height)
(walk-windows (lambda (window) (incf windows)))
(setq tot-win-height
(- (frame-height)
(* window-min-height (1- windows))
2))
(let* ((window-min-height 2)
(height (count-lines (point-min) (point-max)))
(min (max (1- window-min-height) height))
(tot (if (numberp gnus-tree-minimize-window)
(min gnus-tree-minimize-window min)
min))
(win (get-buffer-window (current-buffer)))
(wh (and win (1- (window-height win)))))
(setq tot (min tot tot-win-height))
(when (and win
(not (eq tot wh)))
(let ((selected (selected-window)))
(select-window win)
(enlarge-window (- tot wh))
(select-window selected)))))))
;;; Generating the tree.
(defun gnus-tree-node-insert (header sparse &optional adopted)
(let* ((dummy (stringp header))
(header (if (vectorp header) header
(progn
(setq header (make-mail-header "*****"))
(mail-header-set-number header 0)
(mail-header-set-lines header 0)
(mail-header-set-chars header 0)
header)))
(gnus-tmp-from (mail-header-from header))
(gnus-tmp-subject (mail-header-subject header))
(gnus-tmp-number (mail-header-number header))
(gnus-tmp-name
(cond
((string-match "(.+)" gnus-tmp-from)
(substring gnus-tmp-from
(1+ (match-beginning 0)) (1- (match-end 0))))
((string-match "<[^>]+> *$" gnus-tmp-from)
(let ((beg (match-beginning 0)))
(or (and (string-match "^\"[^\"]*\"" gnus-tmp-from)
(substring gnus-tmp-from (1+ (match-beginning 0))
(1- (match-end 0))))
(substring gnus-tmp-from 0 beg))))
((memq gnus-tmp-number sparse)
"***")
(t gnus-tmp-from)))
(gnus-tmp-open-bracket
(cond ((memq gnus-tmp-number sparse)
(caadr gnus-tree-brackets))
(dummy (caaddr gnus-tree-brackets))
(adopted (car (nth 3 gnus-tree-brackets)))
(t (caar gnus-tree-brackets))))
(gnus-tmp-close-bracket
(cond ((memq gnus-tmp-number sparse)
(cdadr gnus-tree-brackets))
(adopted (cdr (nth 3 gnus-tree-brackets)))
(dummy
(cdaddr gnus-tree-brackets))
(t (cdar gnus-tree-brackets))))
(buffer-read-only nil)
beg end)
(gnus-add-text-properties
(setq beg (point))
(setq end (progn (eval gnus-tree-line-format-spec) (point)))
(list 'gnus-number gnus-tmp-number))
(when (or t (gnus-visual-p 'tree-highlight 'highlight))
(gnus-tree-highlight-node gnus-tmp-number beg end))))
(defun gnus-tree-highlight-node (article beg end)
"Highlight current line according to `gnus-summary-highlight'."
(let ((list gnus-summary-highlight)
face)
(save-excursion
(set-buffer gnus-summary-buffer)
(let* ((score (or (cdr (assq article gnus-newsgroup-scored))
gnus-summary-default-score 0))
(default gnus-summary-default-score)
(mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
;; Eval the cars of the lists until we find a match.
(while (and list
(not (eval (caar list))))
(setq list (cdr list)))))
(unless (eq (setq face (cdar list)) (get-text-property beg 'face))
(gnus-put-text-property
beg end 'face
(if (boundp face) (symbol-value face) face)))))
(defun gnus-tree-indent (level)
(insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? )))
(defvar gnus-tmp-limit)
(defvar gnus-tmp-sparse)
(defvar gnus-tmp-indent)
(defun gnus-generate-tree (thread)
"Generate a thread tree for THREAD."
(save-excursion
(set-buffer (gnus-get-tree-buffer))
(let ((buffer-read-only nil)
(gnus-tmp-indent 0))
(erase-buffer)
(funcall gnus-generate-tree-function thread 0)
(gnus-set-mode-line 'tree)
(goto-char (point-min))
(gnus-tree-minimize)
(gnus-tree-recenter)
(let ((selected (selected-window)))
(when (get-buffer-window (set-buffer gnus-tree-buffer) t)
(select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
(gnus-horizontal-recenter)
(select-window selected))))))
(defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted)
"Generate a horizontal tree."
(let* ((dummy (stringp (car thread)))
(do (or dummy
(memq (mail-header-number (car thread)) gnus-tmp-limit)))
col beg)
(if (not do)
;; We don't want this article.
(setq thread (cdr thread))
(if (not (bolp))
;; Not the first article on the line, so we insert a "-".
(insert (car gnus-tree-parent-child-edges))
;; If the level isn't zero, then we insert some indentation.
(unless (zerop level)
(gnus-tree-indent level)
(insert (cadr gnus-tree-parent-child-edges))
(setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
;; Draw "|" lines upwards.
(while (progn
(forward-line -1)
(forward-char col)
(= (following-char) ? ))
(delete-char 1)
(insert (caddr gnus-tree-parent-child-edges)))
(goto-char beg)))
(setq dummyp nil)
;; Insert the article node.
(gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted))
(if (null thread)
;; End of the thread, so we go to the next line.
(unless (bolp)
(insert "\n"))
;; Recurse downwards in all children of this article.
(while thread
(gnus-generate-horizontal-tree
(pop thread) (if do (1+ level) level)
(or dummyp dummy) dummy)))))
(defsubst gnus-tree-indent-vertical ()
(let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
(- (point) (gnus-point-at-bol)))))
(when (> len 0)
(insert (make-string len ? )))))
(defsubst gnus-tree-forward-line (n)
(while (>= (decf n) 0)
(unless (zerop (forward-line 1))
(end-of-line)
(insert "\n")))
(end-of-line))
(defun gnus-generate-vertical-tree (thread level &optional dummyp adopted)
"Generate a vertical tree."
(let* ((dummy (stringp (car thread)))
(do (or dummy
(memq (mail-header-number (car thread)) gnus-tmp-limit)))
beg)
(if (not do)
;; We don't want this article.
(setq thread (cdr thread))
(if (not (save-excursion (beginning-of-line) (bobp)))
;; Not the first article on the line, so we insert a "-".
(progn
(gnus-tree-indent-vertical)
(insert (make-string (/ gnus-tree-node-length 2) ? ))
(insert (caddr gnus-tree-parent-child-edges))
(gnus-tree-forward-line 1))
;; If the level isn't zero, then we insert some indentation.
(unless (zerop gnus-tmp-indent)
(gnus-tree-forward-line (1- (* 2 level)))
(gnus-tree-indent-vertical)
(delete-char -1)
(insert (cadr gnus-tree-parent-child-edges))
(setq beg (point))
;; Draw "-" lines leftwards.
(while (progn
(forward-char -2)
(= (following-char) ? ))
(delete-char 1)
(insert (car gnus-tree-parent-child-edges)))
(goto-char beg)
(gnus-tree-forward-line 1)))
(setq dummyp nil)
;; Insert the article node.
(gnus-tree-indent-vertical)
(gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)
(gnus-tree-forward-line 1))
(if (null thread)
;; End of the thread, so we go to the next line.
(progn
(goto-char (point-min))
(end-of-line)
(incf gnus-tmp-indent))
;; Recurse downwards in all children of this article.
(while thread
(gnus-generate-vertical-tree
(pop thread) (if do (1+ level) level)
(or dummyp dummy) dummy)))))
;;; Interface functions.
(defun gnus-possibly-generate-tree (article &optional force)
"Generate the thread tree for ARTICLE if it isn't displayed already."
(when (save-excursion
(set-buffer gnus-summary-buffer)
(and gnus-use-trees
(vectorp (gnus-summary-article-header article))))
(save-excursion
(let ((top (save-excursion
(set-buffer gnus-summary-buffer)
(gnus-cut-thread
(gnus-remove-thread
(mail-header-id
(gnus-summary-article-header article)) t))))
(gnus-tmp-limit gnus-newsgroup-limit)
(gnus-tmp-sparse gnus-newsgroup-sparse))
(when (or force
(not (eq top gnus-tree-displayed-thread)))
(gnus-generate-tree top)
(setq gnus-tree-displayed-thread top))))))
(defun gnus-tree-open (group)
(gnus-get-tree-buffer))
(defun gnus-tree-close (group)
;(gnus-kill-buffer gnus-tree-buffer)
)
(defun gnus-highlight-selected-tree (article)
"Highlight the selected article in the tree."
(let ((buf (current-buffer))
region)
(set-buffer gnus-tree-buffer)
(when (setq region (gnus-tree-article-region article))
(when (or (not gnus-selected-tree-overlay)
(gnus-extent-detached-p gnus-selected-tree-overlay))
;; Create a new overlay.
(gnus-overlay-put
(setq gnus-selected-tree-overlay (gnus-make-overlay 1 2))
'face gnus-selected-tree-face))
;; Move the overlay to the article.
(gnus-move-overlay
gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
(gnus-tree-minimize)
(gnus-tree-recenter)
(let ((selected (selected-window)))
(when (get-buffer-window (set-buffer gnus-tree-buffer) t)
(select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
(gnus-horizontal-recenter)
(select-window selected))))
;; If we remove this save-excursion, it updates the wrong mode lines?!?
(save-excursion
(set-buffer gnus-tree-buffer)
(gnus-set-mode-line 'tree))
(set-buffer buf)))
(defun gnus-tree-highlight-article (article face)
(save-excursion
(set-buffer (gnus-get-tree-buffer))
(let (region)
(when (setq region (gnus-tree-article-region article))
(gnus-put-text-property (car region) (cdr region) 'face face)
(set-window-point
(get-buffer-window (current-buffer) t) (cdr region))))))
;;; Allow redefinition of functions.
(gnus-ems-redefine)
(provide 'gnus-salt)
;;; gnus-salt.el ends here

110
lisp/gnus-scomo.el
View file

@ -1,110 +0,0 @@
;;; gnus-scomo.el --- mode for editing Gnus score files
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'easymenu)
(require 'timezone)
(eval-when-compile (require 'cl))
(defvar gnus-score-mode-hook nil
"*Hook run in score mode buffers.")
(defvar gnus-score-menu-hook nil
"*Hook run after creating the score mode menu.")
(defvar gnus-score-edit-exit-function nil
"Function run on exit from the score buffer.")
(defvar gnus-score-mode-map nil)
(unless gnus-score-mode-map
(setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
(define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-exit)
(define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)
(define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print))
;;;###autoload
(defun gnus-score-mode ()
"Mode for editing Gnus score files.
This mode is an extended emacs-lisp mode.
\\{gnus-score-mode-map}"
(interactive)
(kill-all-local-variables)
(use-local-map gnus-score-mode-map)
(when menu-bar-mode
(gnus-score-make-menu-bar))
(set-syntax-table emacs-lisp-mode-syntax-table)
(setq major-mode 'gnus-score-mode)
(setq mode-name "Score")
(lisp-mode-variables nil)
(make-local-variable 'gnus-score-edit-exit-function)
(run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
(defun gnus-score-make-menu-bar ()
(unless (boundp 'gnus-score-menu)
(easy-menu-define
gnus-score-menu gnus-score-mode-map ""
'("Score"
["Exit" gnus-score-edit-exit t]
["Insert date" gnus-score-edit-insert-date t]
["Format" gnus-score-pretty-print t]))
(run-hooks 'gnus-score-menu-hook)))
(defun gnus-score-edit-insert-date ()
"Insert date in numerical format."
(interactive)
(princ (gnus-score-day-number (current-time)) (current-buffer)))
(defun gnus-score-pretty-print ()
"Format the current score file."
(interactive)
(goto-char (point-min))
(let ((form (read (current-buffer))))
(erase-buffer)
(pp form (current-buffer)))
(goto-char (point-min)))
(defun gnus-score-edit-exit ()
"Stop editing the score file."
(interactive)
(unless (file-exists-p (file-name-directory (buffer-file-name)))
(make-directory (file-name-directory (buffer-file-name)) t))
(save-buffer)
(bury-buffer (current-buffer))
(let ((buf (current-buffer)))
(when gnus-score-edit-exit-function
(funcall gnus-score-edit-exit-function))
(when (eq buf (current-buffer))
(switch-to-buffer (other-buffer (current-buffer))))))
(defun gnus-score-day-number (time)
(let ((dat (decode-time time)))
(timezone-absolute-from-gregorian
(nth 4 dat) (nth 3 dat) (nth 5 dat))))
(provide 'gnus-scomo)
;;; gnus-scomo.el ends here

2258
lisp/gnus-score.el
View file

File diff suppressed because it is too large Load diff

210
lisp/gnus-setup.el
View file

@ -1,210 +0,0 @@
;;; gnus-setup.el --- Initialization & Setup for Gnus 5
;; Copyright (C) 1995, 96 Free Software Foundation, Inc.
;; Author: Steven L. Baur <steve@miranova.com>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; My head is starting to spin with all the different mail/news packages.
;; Stop The Madness!
;; Given that Emacs Lisp byte codes may be diverging, it is probably best
;; not to byte compile this, and just arrange to have the .el loaded out
;; of .emacs.
;;; Code:
(defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))
(defvar gnus-emacs-lisp-directory (if running-xemacs
"/usr/local/lib/xemacs/"
"/usr/local/share/emacs/")
"Directory where Emacs site lisp is located.")
(defvar gnus-gnus-lisp-directory (concat gnus-emacs-lisp-directory
"gnus-5.0.15/lisp/")
"Directory where Gnus Emacs lisp is found.")
(defvar gnus-sgnus-lisp-directory (concat gnus-emacs-lisp-directory
"sgnus/lisp/")
"Directory where September Gnus Emacs lisp is found.")
(defvar gnus-tm-lisp-directory (concat gnus-emacs-lisp-directory
"site-lisp/")
"Directory where TM Emacs lisp is found.")
(defvar gnus-mailcrypt-lisp-directory (concat gnus-emacs-lisp-directory
"site-lisp/mailcrypt-3.4/")
"Directory where Mailcrypt Emacs Lisp is found.")
(defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory
"site-lisp/bbdb-1.50/")
"Directory where Big Brother Database is found.")
(defvar gnus-use-tm t
"Set this if you want MIME support for Gnus")
(defvar gnus-use-mhe nil
"Set this if you want to use MH-E for mail reading")
(defvar gnus-use-rmail nil
"Set this if you want to use RMAIL for mail reading")
(defvar gnus-use-sendmail t
"Set this if you want to use SENDMAIL for mail reading")
(defvar gnus-use-vm nil
"Set this if you want to use the VM package for mail reading")
(defvar gnus-use-sc t
"Set this if you want to use Supercite")
(defvar gnus-use-mailcrypt t
"Set this if you want to use Mailcrypt for dealing with PGP messages")
(defvar gnus-use-bbdb nil
"Set this if you want to use the Big Brother DataBase")
(defvar gnus-use-september nil
"Set this if you are using the experimental September Gnus")
(let ((gnus-directory (if gnus-use-september
gnus-sgnus-lisp-directory
gnus-gnus-lisp-directory)))
(if (null (member gnus-directory load-path))
(setq load-path (cons gnus-directory load-path))))
;;; Tools for MIME by
;;; UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
;;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(if gnus-use-tm
(progn
(if (null (member gnus-tm-lisp-directory load-path))
(setq load-path (cons gnus-tm-lisp-directory load-path)))
(load "mime-setup")))
;;; Mailcrypt by
;;; Jin Choi <jin@atype.com>
;;; Patrick LoPresti <patl@lcs.mit.edu>
(if gnus-use-mailcrypt
(progn
(if (null (member gnus-mailcrypt-lisp-directory load-path))
(setq load-path (cons gnus-mailcrypt-lisp-directory load-path)))
(autoload 'mc-install-write-mode "mailcrypt" nil t)
(autoload 'mc-install-read-mode "mailcrypt" nil t)
(add-hook 'message-mode-hook 'mc-install-write-mode)
(add-hook 'gnus-summary-mode-hook 'mc-install-read-mode)
(if gnus-use-mhe
(progn
(add-hook 'mh-folder-mode-hook 'mc-install-read-mode)
(add-hook 'mh-letter-mode-hook 'mc-install-write-mode)))))
;;; BBDB by
;;; Jamie Zawinski <jwz@lucid.com>
(if gnus-use-bbdb
(progn
(if (null (member gnus-bbdb-lisp-directory load-path))
(setq load-path (cons gnus-bbdb-lisp-directory load-path)))
(autoload 'bbdb "bbdb-com"
"Insidious Big Brother Database" t)
(autoload 'bbdb-name "bbdb-com"
"Insidious Big Brother Database" t)
(autoload 'bbdb-company "bbdb-com"
"Insidious Big Brother Database" t)
(autoload 'bbdb-net "bbdb-com"
"Insidious Big Brother Database" t)
(autoload 'bbdb-notes "bbdb-com"
"Insidious Big Brother Database" t)
(if gnus-use-vm
(progn
(autoload 'bbdb-insinuate-vm "bbdb-vm"
"Hook BBDB into VM" t)))
(if gnus-use-rmail
(progn
(autoload 'bbdb-insinuate-rmail "bbdb-rmail"
"Hook BBDB into RMAIL" t)
(add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail)))
(if gnus-use-mhe
(progn
(autoload 'bbdb-insinuate-mh "bbdb-mh"
"Hook BBDB into MH-E" t)
(add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh)))
(autoload 'bbdb-insinuate-gnus "bbdb-gnus"
"Hook BBDB into Gnus" t)
(add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus)
(if gnus-use-sendmail
(progn
(autoload 'bbdb-insinuate-sendmail "bbdb"
"Insidious Big Brother Database" t)
(add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail)
(add-hook 'message-setup-hook 'bbdb-insinuate-sendmail)))))
(if gnus-use-sc
(progn
(add-hook 'mail-citation-hook 'sc-cite-original)
(setq message-cite-function 'sc-cite-original)
(autoload 'sc-cite-original "supercite")))
;;;### (autoloads (gnus-batch-score gnus-fetch-group gnus gnus-slave gnus-no-server gnus-update-format) "gnus" "lisp/gnus.el" (12473 2137))
;;; Generated autoloads from lisp/gnus.el
(autoload 'gnus-update-format "gnus" "\
Update the format specification near point." t nil)
(autoload 'gnus-slave-no-server "gnus" "\
Read network news as a slave without connecting to local server." t nil)
(autoload 'gnus-no-server "gnus" "\
Read network news.
If ARG is a positive number, Gnus will use that as the
startup level. If ARG is nil, Gnus will be started at level 2.
If ARG is non-nil and not a positive number, Gnus will
prompt the user for the name of an NNTP server to use.
As opposed to `gnus', this command will not connect to the local server." t nil)
(autoload 'gnus-slave "gnus" "\
Read news as a slave." t nil)
(autoload 'gnus "gnus" "\
Read network news.
If ARG is non-nil and a positive number, Gnus will use that as the
startup level. If ARG is non-nil and not a positive number, Gnus will
prompt the user for the name of an NNTP server to use." t nil)
(autoload 'gnus-fetch-group "gnus" "\
Start Gnus if necessary and enter GROUP.
Returns whether the fetching was successful or not." t nil)
(defalias 'gnus-batch-kill 'gnus-batch-score)
(autoload 'gnus-batch-score "gnus" "\
Run batched scoring.
Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ...
Newsgroups is a list of strings in Bnews format. If you want to score
the comp hierarchy, you'd say \"comp.all\". If you would not like to
score the alt hierarchy, you'd say \"!alt.all\"." t nil)
;;;***
(provide 'gnus-setup)
(run-hooks 'gnus-setup-load-hook)
;;; gnus-setup.el ends here

563
lisp/gnus-soup.el
View file

@ -1,563 +0,0 @@
;;; gnus-soup.el --- SOUP packet writing support for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus-msg)
(require 'gnus)
(eval-when-compile (require 'cl))
;;; User Variables:
(defvar gnus-soup-directory "~/SoupBrew/"
"*Directory containing an unpacked SOUP packet.")
(defvar gnus-soup-replies-directory (concat gnus-soup-directory "SoupReplies/")
"*Directory where Gnus will do processing of replies.")
(defvar gnus-soup-prefix-file "gnus-prefix"
"*Name of the file where Gnus stores the last used prefix.")
(defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
"Format string command for packing a SOUP packet.
The SOUP files will be inserted where the %s is in the string.
This string MUST contain both %s and %d. The file number will be
inserted where %d appears.")
(defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
"*Format string command for unpacking a SOUP packet.
The SOUP packet file name will be inserted at the %s.")
(defvar gnus-soup-packet-directory "~/"
"*Where gnus-soup will look for REPLIES packets.")
(defvar gnus-soup-packet-regexp "Soupin"
"*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
(defvar gnus-soup-ignored-headers "^Xref:"
"*Regexp to match headers to be removed when brewing SOUP packets.")
;;; Internal Variables:
(defvar gnus-soup-encoding-type ?n
"*Soup encoding type.
`n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
format.")
(defvar gnus-soup-index-type ?c
"*Soup index type.
`n' means no index file and `c' means standard Cnews overview
format.")
(defvar gnus-soup-areas nil)
(defvar gnus-soup-last-prefix nil)
(defvar gnus-soup-prev-prefix nil)
(defvar gnus-soup-buffers nil)
;;; Access macros:
(defmacro gnus-soup-area-prefix (area)
`(aref ,area 0))
(defmacro gnus-soup-set-area-prefix (area prefix)
`(aset ,area 0 ,prefix))
(defmacro gnus-soup-area-name (area)
`(aref ,area 1))
(defmacro gnus-soup-area-encoding (area)
`(aref ,area 2))
(defmacro gnus-soup-area-description (area)
`(aref ,area 3))
(defmacro gnus-soup-area-number (area)
`(aref ,area 4))
(defmacro gnus-soup-area-set-number (area value)
`(aset ,area 4 ,value))
(defmacro gnus-soup-encoding-format (encoding)
`(aref ,encoding 0))
(defmacro gnus-soup-encoding-index (encoding)
`(aref ,encoding 1))
(defmacro gnus-soup-encoding-kind (encoding)
`(aref ,encoding 2))
(defmacro gnus-soup-reply-prefix (reply)
`(aref ,reply 0))
(defmacro gnus-soup-reply-kind (reply)
`(aref ,reply 1))
(defmacro gnus-soup-reply-encoding (reply)
`(aref ,reply 2))
;;; Commands:
(defun gnus-soup-send-replies ()
"Unpack and send all replies in the reply packet."
(interactive)
(let ((packets (directory-files
gnus-soup-packet-directory t gnus-soup-packet-regexp)))
(while packets
(and (gnus-soup-send-packet (car packets))
(delete-file (car packets)))
(setq packets (cdr packets)))))
(defun gnus-soup-add-article (n)
"Add the current article to SOUP packet.
If N is a positive number, add the N next articles.
If N is a negative number, add the N previous articles.
If N is nil and any articles have been marked with the process mark,
move those articles instead."
(interactive "P")
(gnus-set-global-variables)
(let* ((articles (gnus-summary-work-articles n))
(tmp-buf (get-buffer-create "*soup work*"))
(area (gnus-soup-area gnus-newsgroup-name))
(prefix (gnus-soup-area-prefix area))
headers)
(buffer-disable-undo tmp-buf)
(save-excursion
(while articles
;; Find the header of the article.
(set-buffer gnus-summary-buffer)
(when (setq headers (gnus-summary-article-header (car articles)))
;; Put the article in a buffer.
(set-buffer tmp-buf)
(when (gnus-request-article-this-buffer
(car articles) gnus-newsgroup-name)
(save-restriction
(message-narrow-to-head)
(message-remove-header gnus-soup-ignored-headers t))
(gnus-soup-store gnus-soup-directory prefix headers
gnus-soup-encoding-type
gnus-soup-index-type)
(gnus-soup-area-set-number
area (1+ (or (gnus-soup-area-number area) 0)))))
;; Mark article as read.
(set-buffer gnus-summary-buffer)
(gnus-summary-remove-process-mark (car articles))
(gnus-summary-mark-as-read (car articles) gnus-souped-mark)
(setq articles (cdr articles)))
(kill-buffer tmp-buf))
(gnus-soup-save-areas)))
(defun gnus-soup-pack-packet ()
"Make a SOUP packet from the SOUP areas."
(interactive)
(gnus-soup-read-areas)
(gnus-soup-pack gnus-soup-directory gnus-soup-packer))
(defun gnus-group-brew-soup (n)
"Make a soup packet from the current group.
Uses the process/prefix convention."
(interactive "P")
(let ((groups (gnus-group-process-prefix n)))
(while groups
(gnus-group-remove-mark (car groups))
(gnus-soup-group-brew (car groups) t)
(setq groups (cdr groups)))
(gnus-soup-save-areas)))
(defun gnus-brew-soup (&optional level)
"Go through all groups on LEVEL or less and make a soup packet."
(interactive "P")
(let ((level (or level gnus-level-subscribed))
(newsrc (cdr gnus-newsrc-alist)))
(while newsrc
(and (<= (nth 1 (car newsrc)) level)
(gnus-soup-group-brew (caar newsrc) t))
(setq newsrc (cdr newsrc)))
(gnus-soup-save-areas)))
;;;###autoload
(defun gnus-batch-brew-soup ()
"Brew a SOUP packet from groups mention on the command line.
Will use the remaining command line arguments as regular expressions
for matching on group names.
For instance, if you want to brew on all the nnml groups, as well as
groups with \"emacs\" in the name, you could say something like:
$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
(interactive)
)
;;; Internal Functions:
;; Store the current buffer.
(defun gnus-soup-store (directory prefix headers format index)
;; Create the directory, if needed.
(or (file-directory-p directory)
(gnus-make-directory directory))
(let* ((msg-buf (find-file-noselect
(concat directory prefix ".MSG")))
(idx-buf (if (= index ?n)
nil
(find-file-noselect
(concat directory prefix ".IDX"))))
(article-buf (current-buffer))
from head-line beg type)
(setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
(buffer-disable-undo msg-buf)
(and idx-buf
(progn
(setq gnus-soup-buffers (cons idx-buf gnus-soup-buffers))
(buffer-disable-undo idx-buf)))
(save-excursion
;; Make sure the last char in the buffer is a newline.
(goto-char (point-max))
(or (= (current-column) 0)
(insert "\n"))
;; Find the "from".
(goto-char (point-min))
(setq from
(gnus-mail-strip-quoted-names
(or (mail-fetch-field "from")
(mail-fetch-field "really-from")
(mail-fetch-field "sender"))))
(goto-char (point-min))
;; Depending on what encoding is supposed to be used, we make
;; a soup header.
(setq head-line
(cond
((= gnus-soup-encoding-type ?n)
(format "#! rnews %d\n" (buffer-size)))
((= gnus-soup-encoding-type ?m)
(while (search-forward "\nFrom " nil t)
(replace-match "\n>From " t t))
(concat "From " (or from "unknown")
" " (current-time-string) "\n"))
((= gnus-soup-encoding-type ?M)
"\^a\^a\^a\^a\n")
(t (error "Unsupported type: %c" gnus-soup-encoding-type))))
;; Insert the soup header and the article in the MSG buf.
(set-buffer msg-buf)
(goto-char (point-max))
(insert head-line)
(setq beg (point))
(insert-buffer-substring article-buf)
;; Insert the index in the IDX buf.
(cond ((= index ?c)
(set-buffer idx-buf)
(gnus-soup-insert-idx beg headers))
((/= index ?n)
(error "Unknown index type: %c" type)))
;; Return the MSG buf.
msg-buf)))
(defun gnus-soup-group-brew (group &optional not-all)
"Enter GROUP and add all articles to a SOUP package.
If NOT-ALL, don't pack ticked articles."
(let ((gnus-expert-user t)
(gnus-large-newsgroup nil)
(entry (gnus-gethash group gnus-newsrc-hashtb)))
(when (or (null entry)
(eq (car entry) t)
(and (car entry)
(> (car entry) 0))
(and (not not-all)
(gnus-range-length (cdr (assq 'tick (gnus-info-marks
(nth 2 entry)))))))
(when (gnus-summary-read-group group nil t)
(setq gnus-newsgroup-processable
(reverse
(if (not not-all)
(append gnus-newsgroup-marked gnus-newsgroup-unreads)
gnus-newsgroup-unreads)))
(gnus-soup-add-article nil)
(gnus-summary-exit)))))
(defun gnus-soup-insert-idx (offset header)
;; [number subject from date id references chars lines xref]
(goto-char (point-max))
(insert
(format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n"
offset
(or (mail-header-subject header) "(none)")
(or (mail-header-from header) "(nobody)")
(or (mail-header-date header) "")
(or (mail-header-id header)
(concat "soup-dummy-id-"
(mapconcat
(lambda (time) (int-to-string time))
(current-time) "-")))
(or (mail-header-references header) "")
(or (mail-header-chars header) 0)
(or (mail-header-lines header) "0"))))
(defun gnus-soup-save-areas ()
(gnus-soup-write-areas)
(save-excursion
(let (buf)
(while gnus-soup-buffers
(setq buf (car gnus-soup-buffers)
gnus-soup-buffers (cdr gnus-soup-buffers))
(if (not (buffer-name buf))
()
(set-buffer buf)
(and (buffer-modified-p) (save-buffer))
(kill-buffer (current-buffer)))))
(gnus-soup-write-prefixes)))
(defun gnus-soup-write-prefixes ()
(let ((prefix gnus-soup-last-prefix))
(save-excursion
(while prefix
(gnus-set-work-buffer)
(insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdar prefix)))
(gnus-make-directory (caar prefix))
(write-region (point-min) (point-max)
(concat (caar prefix) gnus-soup-prefix-file)
nil 'nomesg)
(setq prefix (cdr prefix))))))
(defun gnus-soup-pack (dir packer)
(let* ((files (mapconcat 'identity
'("AREAS" "*.MSG" "*.IDX" "INFO"
"LIST" "REPLIES" "COMMANDS" "ERRORS")
" "))
(packer (if (< (string-match "%s" packer)
(string-match "%d" packer))
(format packer files
(string-to-int (gnus-soup-unique-prefix dir)))
(format packer
(string-to-int (gnus-soup-unique-prefix dir))
files)))
(dir (expand-file-name dir)))
(or (file-directory-p dir)
(gnus-make-directory dir))
(setq gnus-soup-areas nil)
(gnus-message 4 "Packing %s..." packer)
(if (zerop (call-process shell-file-name
nil nil nil shell-command-switch
(concat "cd " dir " ; " packer)))
(progn
(call-process shell-file-name nil nil nil shell-command-switch
(concat "cd " dir " ; rm " files))
(gnus-message 4 "Packing...done" packer))
(error "Couldn't pack packet."))))
(defun gnus-soup-parse-areas (file)
"Parse soup area file FILE.
The result is a of vectors, each containing one entry from the AREA file.
The vector contain five strings,
[prefix name encoding description number]
though the two last may be nil if they are missing."
(let (areas)
(save-excursion
(set-buffer (find-file-noselect file 'force))
(buffer-disable-undo (current-buffer))
(goto-char (point-min))
(while (not (eobp))
(setq areas
(cons (vector (gnus-soup-field)
(gnus-soup-field)
(gnus-soup-field)
(and (eq (preceding-char) ?\t)
(gnus-soup-field))
(and (eq (preceding-char) ?\t)
(string-to-int (gnus-soup-field))))
areas))
(if (eq (preceding-char) ?\t)
(beginning-of-line 2)))
(kill-buffer (current-buffer)))
areas))
(defun gnus-soup-parse-replies (file)
"Parse soup REPLIES file FILE.
The result is a of vectors, each containing one entry from the REPLIES
file. The vector contain three strings, [prefix name encoding]."
(let (replies)
(save-excursion
(set-buffer (find-file-noselect file))
(buffer-disable-undo (current-buffer))
(goto-char (point-min))
(while (not (eobp))
(setq replies
(cons (vector (gnus-soup-field) (gnus-soup-field)
(gnus-soup-field))
replies))
(if (eq (preceding-char) ?\t)
(beginning-of-line 2)))
(kill-buffer (current-buffer)))
replies))
(defun gnus-soup-field ()
(prog1
(buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
(forward-char 1)))
(defun gnus-soup-read-areas ()
(or gnus-soup-areas
(setq gnus-soup-areas
(gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
(defun gnus-soup-write-areas ()
"Write the AREAS file."
(interactive)
(when gnus-soup-areas
(nnheader-temp-write (concat gnus-soup-directory "AREAS")
(let ((areas gnus-soup-areas)
area)
(while (setq area (pop areas))
(insert
(format
"%s\t%s\t%s%s\n"
(gnus-soup-area-prefix area)
(gnus-soup-area-name area)
(gnus-soup-area-encoding area)
(if (or (gnus-soup-area-description area)
(gnus-soup-area-number area))
(concat "\t" (or (gnus-soup-area-description
area) "")
(if (gnus-soup-area-number area)
(concat "\t" (int-to-string
(gnus-soup-area-number area)))
"")) ""))))))))
(defun gnus-soup-write-replies (dir areas)
"Write a REPLIES file in DIR containing AREAS."
(nnheader-temp-write (concat dir "REPLIES")
(let (area)
(while (setq area (pop areas))
(insert (format "%s\t%s\t%s\n"
(gnus-soup-reply-prefix area)
(gnus-soup-reply-kind area)
(gnus-soup-reply-encoding area)))))))
(defun gnus-soup-area (group)
(gnus-soup-read-areas)
(let ((areas gnus-soup-areas)
(real-group (gnus-group-real-name group))
area result)
(while areas
(setq area (car areas)
areas (cdr areas))
(if (equal (gnus-soup-area-name area) real-group)
(setq result area)))
(or result
(setq result
(vector (gnus-soup-unique-prefix)
real-group
(format "%c%c%c"
gnus-soup-encoding-type
gnus-soup-index-type
(if (gnus-member-of-valid 'mail group) ?m ?n))
nil nil)
gnus-soup-areas (cons result gnus-soup-areas)))
result))
(defun gnus-soup-unique-prefix (&optional dir)
(let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
(entry (assoc dir gnus-soup-last-prefix))
gnus-soup-prev-prefix)
(if entry
()
(and (file-exists-p (concat dir gnus-soup-prefix-file))
(condition-case nil
(load (concat dir gnus-soup-prefix-file) nil t t)
(error nil)))
(setq gnus-soup-last-prefix
(cons (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
gnus-soup-last-prefix)))
(setcdr entry (1+ (cdr entry)))
(gnus-soup-write-prefixes)
(int-to-string (cdr entry))))
(defun gnus-soup-unpack-packet (dir unpacker packet)
"Unpack PACKET into DIR using UNPACKER.
Return whether the unpacking was successful."
(gnus-make-directory dir)
(gnus-message 4 "Unpacking: %s" (format unpacker packet))
(prog1
(zerop (call-process
shell-file-name nil nil nil shell-command-switch
(format "cd %s ; %s" (expand-file-name dir)
(format unpacker packet))))
(gnus-message 4 "Unpacking...done")))
(defun gnus-soup-send-packet (packet)
(gnus-soup-unpack-packet
gnus-soup-replies-directory gnus-soup-unpacker packet)
(let ((replies (gnus-soup-parse-replies
(concat gnus-soup-replies-directory "REPLIES"))))
(save-excursion
(while replies
(let* ((msg-file (concat gnus-soup-replies-directory
(gnus-soup-reply-prefix (car replies))
".MSG"))
(msg-buf (and (file-exists-p msg-file)
(find-file-noselect msg-file)))
(tmp-buf (get-buffer-create " *soup send*"))
beg end)
(cond
((/= (gnus-soup-encoding-format
(gnus-soup-reply-encoding (car replies))) ?n)
(error "Unsupported encoding"))
((null msg-buf)
t)
(t
(buffer-disable-undo msg-buf)
(buffer-disable-undo tmp-buf)
(set-buffer msg-buf)
(goto-char (point-min))
(while (not (eobp))
(or (looking-at "#! *rnews +\\([0-9]+\\)")
(error "Bad header."))
(forward-line 1)
(setq beg (point)
end (+ (point) (string-to-int
(buffer-substring
(match-beginning 1) (match-end 1)))))
(switch-to-buffer tmp-buf)
(erase-buffer)
(insert-buffer-substring msg-buf beg end)
(goto-char (point-min))
(search-forward "\n\n")
(forward-char -1)
(insert mail-header-separator)
(setq message-newsreader (setq message-mailer
(gnus-extended-version)))
(cond
((string= (gnus-soup-reply-kind (car replies)) "news")
(gnus-message 5 "Sending news message to %s..."
(mail-fetch-field "newsgroups"))
(sit-for 1)
(funcall message-send-news-function))
((string= (gnus-soup-reply-kind (car replies)) "mail")
(gnus-message 5 "Sending mail to %s..."
(mail-fetch-field "to"))
(sit-for 1)
(message-send-mail))
(t
(error "Unknown reply kind")))
(set-buffer msg-buf)
(goto-char end))
(delete-file (buffer-file-name))
(kill-buffer msg-buf)
(kill-buffer tmp-buf)
(gnus-message 4 "Sent packet"))))
(setq replies (cdr replies)))
t)))
(provide 'gnus-soup)
;;; gnus-soup.el ends here

708
lisp/gnus-srvr.el
View file

@ -1,708 +0,0 @@
;;; gnus-srvr.el --- virtual server support for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'gnus)
(eval-when-compile (require 'cl))
(defvar gnus-server-mode-hook nil
"Hook run in `gnus-server-mode' buffers.")
(defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
"Format of server lines.
It works along the same lines as a normal formatting string,
with some simple extensions.")
(defvar gnus-server-mode-line-format "Gnus List of servers"
"The format specification for the server mode line.")
(defvar gnus-server-exit-hook nil
"*Hook run when exiting the server buffer.")
;;; Internal variables.
(defvar gnus-inserted-opened-servers nil)
(defvar gnus-server-line-format-alist
`((?h how ?s)
(?n name ?s)
(?w where ?s)
(?s status ?s)))
(defvar gnus-server-mode-line-format-alist
`((?S news-server ?s)
(?M news-method ?s)
(?u user-defined ?s)))
(defvar gnus-server-line-format-spec nil)
(defvar gnus-server-mode-line-format-spec nil)
(defvar gnus-server-killed-servers nil)
(defvar gnus-server-mode-map)
(defvar gnus-server-menu-hook nil
"*Hook run after the creation of the server mode menu.")
(defun gnus-server-make-menu-bar ()
(gnus-visual-turn-off-edit-menu 'server)
(unless (boundp 'gnus-server-server-menu)
(easy-menu-define
gnus-server-server-menu gnus-server-mode-map ""
'("Server"
["Add" gnus-server-add-server t]
["Browse" gnus-server-read-server t]
["List" gnus-server-list-servers t]
["Kill" gnus-server-kill-server t]
["Yank" gnus-server-yank-server t]
["Copy" gnus-server-copy-server t]
["Edit" gnus-server-edit-server t]
["Exit" gnus-server-exit t]
))
(easy-menu-define
gnus-server-connections-menu gnus-server-mode-map ""
'("Connections"
["Open" gnus-server-open-server t]
["Close" gnus-server-close-server t]
["Deny" gnus-server-deny-server t]
["Reset" gnus-server-remove-denials t]
))
(run-hooks 'gnus-server-menu-hook)))
(defvar gnus-server-mode-map nil)
(put 'gnus-server-mode 'mode-class 'special)
(unless gnus-server-mode-map
(setq gnus-server-mode-map (make-sparse-keymap))
(suppress-keymap gnus-server-mode-map)
(gnus-define-keys
gnus-server-mode-map
" " gnus-server-read-server
"\r" gnus-server-read-server
gnus-mouse-2 gnus-server-pick-server
"q" gnus-server-exit
"l" gnus-server-list-servers
"k" gnus-server-kill-server
"y" gnus-server-yank-server
"c" gnus-server-copy-server
"a" gnus-server-add-server
"e" gnus-server-edit-server
"O" gnus-server-open-server
"C" gnus-server-close-server
"D" gnus-server-deny-server
"R" gnus-server-remove-denials
"\C-c\C-i" gnus-info-find-node))
(defun gnus-server-mode ()
"Major mode for listing and editing servers.
All normal editing commands are switched off.
\\<gnus-server-mode-map>
For more in-depth information on this mode, read the manual
(`\\[gnus-info-find-node]').
The following commands are available:
\\{gnus-server-mode-map}"
(interactive)
(when (and menu-bar-mode
(gnus-visual-p 'server-menu 'menu))
(gnus-server-make-menu-bar))
(kill-all-local-variables)
(gnus-simplify-mode-line)
(setq major-mode 'gnus-server-mode)
(setq mode-name "Server")
; (gnus-group-set-mode-line)
(setq mode-line-process nil)
(use-local-map gnus-server-mode-map)
(buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(setq buffer-read-only t)
(run-hooks 'gnus-server-mode-hook))
(defun gnus-server-insert-server-line (name method)
(let* ((how (car method))
(where (nth 1 method))
(elem (assoc method gnus-opened-servers))
(status (cond ((eq (nth 1 elem) 'denied)
"(denied)")
((or (gnus-server-opened method)
(eq (nth 1 elem) 'ok))
"(opened)")
(t
"(closed)"))))
(beginning-of-line)
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
;; Insert the text.
(eval gnus-server-line-format-spec))
(list 'gnus-server (intern name)))))
(defun gnus-enter-server-buffer ()
"Set up the server buffer."
(gnus-server-setup-buffer)
(gnus-configure-windows 'server)
(gnus-server-prepare))
(defun gnus-server-setup-buffer ()
"Initialize the server buffer."
(unless (get-buffer gnus-server-buffer)
(save-excursion
(set-buffer (get-buffer-create gnus-server-buffer))
(gnus-server-mode)
(when gnus-carpal
(gnus-carpal-setup-buffer 'server)))))
(defun gnus-server-prepare ()
(setq gnus-server-mode-line-format-spec
(gnus-parse-format gnus-server-mode-line-format
gnus-server-mode-line-format-alist))
(setq gnus-server-line-format-spec
(gnus-parse-format gnus-server-line-format
gnus-server-line-format-alist t))
(let ((alist gnus-server-alist)
(buffer-read-only nil)
(opened gnus-opened-servers)
done server op-ser)
(erase-buffer)
(setq gnus-inserted-opened-servers nil)
;; First we do the real list of servers.
(while alist
(push (cdr (setq server (pop alist))) done)
(when (and server (car server) (cdr server))
(gnus-server-insert-server-line (car server) (cdr server))))
;; Then we insert the list of servers that have been opened in
;; this session.
(while opened
(unless (member (caar opened) done)
(gnus-server-insert-server-line
(setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
(caar opened))
(push (list op-ser (caar opened)) gnus-inserted-opened-servers))
(setq opened (cdr opened))))
(goto-char (point-min))
(gnus-server-position-point))
(defun gnus-server-server-name ()
(let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
(and server (symbol-name server))))
(defalias 'gnus-server-position-point 'gnus-goto-colon)
(defconst gnus-server-edit-buffer "*Gnus edit server*")
(defun gnus-server-update-server (server)
(save-excursion
(set-buffer gnus-server-buffer)
(let* ((buffer-read-only nil)
(entry (assoc server gnus-server-alist))
(oentry (assoc (gnus-server-to-method server)
gnus-opened-servers)))
(when entry
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
(prin1-to-string (cdr entry)) ")")))
(when (or entry oentry)
;; Buffer may be narrowed.
(save-restriction
(widen)
(when (gnus-server-goto-server server)
(gnus-delete-line))
(if entry
(gnus-server-insert-server-line (car entry) (cdr entry))
(gnus-server-insert-server-line
(format "%s:%s" (caar oentry) (nth 1 (car oentry)))
(car oentry)))
(gnus-server-position-point))))))
(defun gnus-server-set-info (server info)
;; Enter a select method into the virtual server alist.
(when (and server info)
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
(prin1-to-string info) ")"))
(let* ((server (nth 1 info))
(entry (assoc server gnus-server-alist)))
(if entry (setcdr entry info)
(setq gnus-server-alist
(nconc gnus-server-alist (list (cons server info))))))))
;;; Interactive server functions.
(defun gnus-server-kill-server (server)
"Kill the server on the current line."
(interactive (list (gnus-server-server-name)))
(unless (gnus-server-goto-server server)
(if server (error "No such server: %s" server)
(error "No server on the current line")))
(unless (assoc server gnus-server-alist)
(error "Read-only server %s" server))
(gnus-dribble-enter "")
(let ((buffer-read-only nil))
(gnus-delete-line))
(setq gnus-server-killed-servers
(cons (assoc server gnus-server-alist) gnus-server-killed-servers))
(setq gnus-server-alist (delq (car gnus-server-killed-servers)
gnus-server-alist))
(gnus-server-position-point))
(defun gnus-server-yank-server ()
"Yank the previously killed server."
(interactive)
(or gnus-server-killed-servers
(error "No killed servers to be yanked"))
(let ((alist gnus-server-alist)
(server (gnus-server-server-name))
(killed (car gnus-server-killed-servers)))
(if (not server)
(setq gnus-server-alist (nconc gnus-server-alist (list killed)))
(if (string= server (caar gnus-server-alist))
(setq gnus-server-alist (cons killed gnus-server-alist))
(while (and (cdr alist)
(not (string= server (caadr alist))))
(setq alist (cdr alist)))
(if alist
(setcdr alist (cons killed (cdr alist)))
(setq gnus-server-alist (list killed)))))
(gnus-server-update-server (car killed))
(setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
(gnus-server-position-point)))
(defun gnus-server-exit ()
"Return to the group buffer."
(interactive)
(kill-buffer (current-buffer))
(switch-to-buffer gnus-group-buffer)
(run-hooks 'gnus-server-exit-hook))
(defun gnus-server-list-servers ()
"List all available servers."
(interactive)
(let ((cur (gnus-server-server-name)))
(gnus-server-prepare)
(if cur (gnus-server-goto-server cur)
(goto-char (point-max))
(forward-line -1))
(gnus-server-position-point)))
(defun gnus-server-set-status (method status)
"Make METHOD have STATUS."
(let ((entry (assoc method gnus-opened-servers)))
(if entry
(setcar (cdr entry) status)
(push (list method status) gnus-opened-servers))))
(defun gnus-opened-servers-remove (method)
"Remove METHOD from the list of opened servers."
(setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
gnus-opened-servers)))
(defun gnus-server-open-server (server)
"Force an open of SERVER."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(or method (error "No such server: %s" server))
(gnus-server-set-status method 'ok)
(prog1
(or (gnus-open-server method)
(progn (message "Couldn't open %s" server) nil))
(gnus-server-update-server server)
(gnus-server-position-point))))
(defun gnus-server-close-server (server)
"Close SERVER."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(or method (error "No such server: %s" server))
(gnus-server-set-status method 'closed)
(prog1
(gnus-close-server method)
(gnus-server-update-server server)
(gnus-server-position-point))))
(defun gnus-server-deny-server (server)
"Make sure SERVER will never be attempted opened."
(interactive (list (gnus-server-server-name)))
(let ((method (gnus-server-to-method server)))
(or method (error "No such server: %s" server))
(gnus-server-set-status method 'denied))
(gnus-server-update-server server)
(gnus-server-position-point)
t)
(defun gnus-server-remove-denials ()
"Make all denied servers into closed servers."
(interactive)
(let ((servers gnus-opened-servers))
(while servers
(when (eq (nth 1 (car servers)) 'denied)
(setcar (nthcdr 1 (car servers)) 'closed))
(setq servers (cdr servers))))
(gnus-server-list-servers))
(defun gnus-server-copy-server (from to)
(interactive
(list
(or (gnus-server-server-name)
(error "No server on the current line"))
(read-string "Copy to: ")))
(or from (error "No server on current line"))
(or (and to (not (string= to ""))) (error "No name to copy to"))
(and (assoc to gnus-server-alist) (error "%s already exists" to))
(or (assoc from gnus-server-alist)
(error "%s: no such server" from))
(let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
(setcar to-entry to)
(setcar (nthcdr 2 to-entry) to)
(setq gnus-server-killed-servers
(cons to-entry gnus-server-killed-servers))
(gnus-server-yank-server)))
(defun gnus-server-add-server (how where)
(interactive
(list (intern (completing-read "Server method: "
gnus-valid-select-methods nil t))
(read-string "Server name: ")))
(setq gnus-server-killed-servers
(cons (list where how where) gnus-server-killed-servers))
(gnus-server-yank-server))
(defun gnus-server-goto-server (server)
"Jump to a server line."
(interactive
(list (completing-read "Goto server: " gnus-server-alist nil t)))
(let ((to (text-property-any (point-min) (point-max)
'gnus-server (intern server))))
(and to
(progn
(goto-char to)
(gnus-server-position-point)))))
(defun gnus-server-edit-server (server)
"Edit the server on the current line."
(interactive (list (gnus-server-server-name)))
(unless server
(error "No server on current line"))
(unless (assoc server gnus-server-alist)
(error "This server can't be edited"))
(let ((winconf (current-window-configuration))
(info (cdr (assoc server gnus-server-alist))))
(gnus-close-server info)
(get-buffer-create gnus-server-edit-buffer)
(gnus-configure-windows 'edit-server)
(gnus-add-current-to-buffer-list)
(emacs-lisp-mode)
(make-local-variable 'gnus-prev-winconf)
(setq gnus-prev-winconf winconf)
(use-local-map (copy-keymap (current-local-map)))
(let ((done-func '(lambda ()
"Exit editing mode and update the information."
(interactive)
(gnus-server-edit-server-done 'group))))
(setcar (cdr (nth 4 done-func)) server)
(local-set-key "\C-c\C-c" done-func))
(erase-buffer)
(insert ";; Type `C-c C-c' after you have edited the server.\n\n")
(insert (pp-to-string info))))
(defun gnus-server-edit-server-done (server)
(interactive)
(set-buffer (get-buffer-create gnus-server-edit-buffer))
(goto-char (point-min))
(let ((form (read (current-buffer)))
(winconf gnus-prev-winconf))
(gnus-server-set-info server form)
(kill-buffer (current-buffer))
(and winconf (set-window-configuration winconf))
(set-buffer gnus-server-buffer)
(gnus-server-update-server server)
(gnus-server-list-servers)
(gnus-server-position-point)))
(defun gnus-server-read-server (server)
"Browse a server."
(interactive (list (gnus-server-server-name)))
(let ((buf (current-buffer)))
(prog1
(gnus-browse-foreign-server (gnus-server-to-method server) buf)
(save-excursion
(set-buffer buf)
(gnus-server-update-server (gnus-server-server-name))
(gnus-server-position-point)))))
(defun gnus-server-pick-server (e)
(interactive "e")
(mouse-set-point e)
(gnus-server-read-server (gnus-server-server-name)))
;;;
;;; Browse Server Mode
;;;
(defvar gnus-browse-menu-hook nil
"*Hook run after the creation of the browse mode menu.")
(defvar gnus-browse-mode-hook nil)
(defvar gnus-browse-mode-map nil)
(put 'gnus-browse-mode 'mode-class 'special)
(unless gnus-browse-mode-map
(setq gnus-browse-mode-map (make-keymap))
(suppress-keymap gnus-browse-mode-map)
(gnus-define-keys
gnus-browse-mode-map
" " gnus-browse-read-group
"=" gnus-browse-select-group
"n" gnus-browse-next-group
"p" gnus-browse-prev-group
"\177" gnus-browse-prev-group
"N" gnus-browse-next-group
"P" gnus-browse-prev-group
"\M-n" gnus-browse-next-group
"\M-p" gnus-browse-prev-group
"\r" gnus-browse-select-group
"u" gnus-browse-unsubscribe-current-group
"l" gnus-browse-exit
"L" gnus-browse-exit
"q" gnus-browse-exit
"Q" gnus-browse-exit
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
"\C-c\C-i" gnus-info-find-node))
(defun gnus-browse-make-menu-bar ()
(gnus-visual-turn-off-edit-menu 'browse)
(or
(boundp 'gnus-browse-menu)
(progn
(easy-menu-define
gnus-browse-menu gnus-browse-mode-map ""
'("Browse"
["Subscribe" gnus-browse-unsubscribe-current-group t]
["Read" gnus-browse-read-group t]
["Select" gnus-browse-read-group t]
["Next" gnus-browse-next-group t]
["Prev" gnus-browse-next-group t]
["Exit" gnus-browse-exit t]
))
(run-hooks 'gnus-browse-menu-hook))))
(defvar gnus-browse-current-method nil)
(defvar gnus-browse-return-buffer nil)
(defvar gnus-browse-buffer "*Gnus Browse Server*")
(defun gnus-browse-foreign-server (method &optional return-buffer)
"Browse the server METHOD."
(setq gnus-browse-current-method method)
(setq gnus-browse-return-buffer return-buffer)
(let ((gnus-select-method method)
groups group)
(gnus-message 5 "Connecting to %s..." (nth 1 method))
(cond
((not (gnus-check-server method))
(gnus-message
1 "Unable to contact server: %s" (gnus-status-message method))
nil)
((not (gnus-request-list method))
(gnus-message
1 "Couldn't request list: %s" (gnus-status-message method))
nil)
(t
(get-buffer-create gnus-browse-buffer)
(gnus-add-current-to-buffer-list)
(and gnus-carpal (gnus-carpal-setup-buffer 'browse))
(gnus-configure-windows 'browse)
(buffer-disable-undo (current-buffer))
(let ((buffer-read-only nil))
(erase-buffer))
(gnus-browse-mode)
(setq mode-line-buffer-identification
(list
(format
"Gnus: %%b {%s:%s}" (car method) (cadr method))))
(save-excursion
(set-buffer nntp-server-buffer)
(let ((cur (current-buffer)))
(goto-char (point-min))
(or (string= gnus-ignored-newsgroups "")
(delete-matching-lines gnus-ignored-newsgroups))
(while (re-search-forward
"\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
(goto-char (match-end 1))
(setq groups (cons (cons (match-string 1)
(max 0 (- (1+ (read cur)) (read cur))))
groups)))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
(let ((buffer-read-only nil))
(while groups
(setq group (car groups))
(insert
(format "K%7d: %s\n" (cdr group) (car group)))
(setq groups (cdr groups))))
(switch-to-buffer (current-buffer))
(goto-char (point-min))
(gnus-group-position-point)
(gnus-message 5 "Connecting to %s...done" (nth 1 method))
t))))
(defun gnus-browse-mode ()
"Major mode for browsing a foreign server.
All normal editing commands are switched off.
\\<gnus-browse-mode-map>
The only things you can do in this buffer is
1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
The group will be inserted into the group buffer upon exit from this
buffer.
2) `\\[gnus-browse-read-group]' to read a group ephemerally.
3) `\\[gnus-browse-exit]' to return to the group buffer."
(interactive)
(kill-all-local-variables)
(when (and menu-bar-mode
(gnus-visual-p 'browse-menu 'menu))
(gnus-browse-make-menu-bar))
(gnus-simplify-mode-line)
(setq major-mode 'gnus-browse-mode)
(setq mode-name "Browse Server")
(setq mode-line-process nil)
(use-local-map gnus-browse-mode-map)
(buffer-disable-undo (current-buffer))
(setq truncate-lines t)
(setq buffer-read-only t)
(run-hooks 'gnus-browse-mode-hook))
(defun gnus-browse-read-group (&optional no-article)
"Enter the group at the current line."
(interactive)
(let ((group (gnus-browse-group-name)))
(or (gnus-group-read-ephemeral-group
group gnus-browse-current-method nil
(cons (current-buffer) 'browse))
(error "Couldn't enter %s" group))))
(defun gnus-browse-select-group ()
"Select the current group."
(interactive)
(gnus-browse-read-group 'no))
(defun gnus-browse-next-group (n)
"Go to the next group."
(interactive "p")
(prog1
(forward-line n)
(gnus-group-position-point)))
(defun gnus-browse-prev-group (n)
"Go to the next group."
(interactive "p")
(gnus-browse-next-group (- n)))
(defun gnus-browse-unsubscribe-current-group (arg)
"(Un)subscribe to the next ARG groups."
(interactive "p")
(when (eobp)
(error "No group at current line."))
(let ((ward (if (< arg 0) -1 1))
(arg (abs arg)))
(while (and (> arg 0)
(not (eobp))
(gnus-browse-unsubscribe-group)
(zerop (gnus-browse-next-group ward)))
(decf arg))
(gnus-group-position-point)
(if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
arg))
(defun gnus-browse-group-name ()
(save-excursion
(beginning-of-line)
(when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
(gnus-group-prefixed-name (match-string 1) gnus-browse-current-method))))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
(let ((sub nil)
(buffer-read-only nil)
group)
(save-excursion
(beginning-of-line)
;; If this group it killed, then we want to subscribe it.
(if (= (following-char) ?K) (setq sub t))
(setq group (gnus-browse-group-name))
(delete-char 1)
(if sub
(progn
(gnus-group-change-level
(list t group gnus-level-default-subscribed
nil nil gnus-browse-current-method)
gnus-level-default-subscribed gnus-level-killed
(and (car (nth 1 gnus-newsrc-alist))
(gnus-gethash (car (nth 1 gnus-newsrc-alist))
gnus-newsrc-hashtb))
t)
(insert ? ))
(gnus-group-change-level
group gnus-level-killed gnus-level-default-subscribed)
(insert ?K)))
t))
(defun gnus-browse-exit ()
"Quit browsing and return to the group buffer."
(interactive)
(when (eq major-mode 'gnus-browse-mode)
(kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-list-groups nil))
(if gnus-browse-return-buffer
(gnus-configure-windows 'server 'force)
(gnus-configure-windows 'group 'force)))
(defun gnus-browse-describe-briefly ()
"Give a one line description of the group mode commands."
(interactive)
(gnus-message 6
(substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help")))
(provide 'gnus-srvr)
;;; gnus-srvr.el ends here.

1057
lisp/gnus-topic.el
View file

File diff suppressed because it is too large Load diff

1951
lisp/gnus-uu.el
View file

File diff suppressed because it is too large Load diff

1615
lisp/gnus-vis.el
View file

File diff suppressed because it is too large Load diff

111
lisp/gnus-vm.el
View file

@ -1,111 +0,0 @@
;;; gnus-vm.el --- vm interface for Gnus
;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
;; Author: Per Persson <pp@solace.mh.se>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Major contributors:
;; Christian Limpach <Christian.Limpach@nice.ch>
;; Some code stolen from:
;; Rick Sladkey <jrs@world.std.com>
;;; Code:
(require 'sendmail)
(require 'message)
(require 'gnus)
(require 'gnus-msg)
(eval-when-compile
(autoload 'vm-mode "vm")
(autoload 'vm-save-message "vm")
(autoload 'vm-forward-message "vm")
(autoload 'vm-reply "vm")
(autoload 'vm-mail "vm"))
(defvar gnus-vm-inhibit-window-system nil
"Inhibit loading `win-vm' if using a window-system.
Has to be set before gnus-vm is loaded.")
(or gnus-vm-inhibit-window-system
(condition-case nil
(if window-system
(require 'win-vm))
(error nil)))
(if (not (featurep 'vm))
(load "vm"))
(defun gnus-vm-make-folder (&optional buffer)
(let ((article (or buffer (current-buffer)))
(tmp-folder (generate-new-buffer " *tmp-folder*"))
(start (point-min))
(end (point-max)))
(set-buffer tmp-folder)
(insert-buffer-substring article start end)
(goto-char (point-min))
(if (looking-at "^\\(From [^ ]+ \\).*$")
(replace-match (concat "\\1" (current-time-string)))
(insert "From " gnus-newsgroup-name " "
(current-time-string) "\n"))
(while (re-search-forward "\n\nFrom " nil t)
(replace-match "\n\n>From "))
;; insert a newline, otherwise the last line gets lost
(goto-char (point-max))
(insert "\n")
(vm-mode)
tmp-folder))
(defun gnus-summary-save-article-vm (&optional arg)
"Append the current article to a vm folder.
If N is a positive number, save the N next articles.
If N is a negative number, save the N previous articles.
If N is nil and any articles have been marked with the process mark,
save those articles instead."
(interactive "P")
(let ((gnus-default-article-saver 'gnus-summary-save-in-vm))
(gnus-summary-save-article arg)))
(defun gnus-summary-save-in-vm (&optional folder)
(interactive)
(let ((default-name
(funcall gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers gnus-newsgroup-last-mail)))
(setq folder
(cond ((eq folder 'default) default-name)
(folder folder)
(t (gnus-read-save-file-name
"Save article in VM folder:" default-name))))
(gnus-make-directory (file-name-directory folder))
(set-buffer gnus-original-article-buffer)
(save-excursion
(save-restriction
(widen)
(let ((vm-folder (gnus-vm-make-folder)))
(vm-save-message folder)
(kill-buffer vm-folder))))
;; Remember the directory name to save articles.
(setq gnus-newsgroup-last-mail folder)))
(provide 'gnus-vm)
;;; gnus-vm.el ends here.

17270
lisp/gnus.el
View file

File diff suppressed because it is too large Load diff

124
lisp/iso02-acc.el
View file

@ -1,124 +0,0 @@
;;; iso02-acc.el --- electric accent keys for Eastern Europe (ISO latin2)
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(defvar iso-accents-list
'(((?' ?A) ?\301)
((?' ?C) ?\306)
((?' ?D) ?\320)
((?' ?E) ?\311)
((?' ?I) ?\315)
((?' ?L) ?\305)
((?' ?N) ?\321)
((?' ?O) ?\323)
((?' ?R) ?\300)
((?' ?S) ?\246)
((?' ?U) ?\332)
((?' ?Y) ?\335)
((?' ?Z) ?\254)
((?' ?a) ?\341)
((?' ?c) ?\346)
((?' ?d) ?\360)
((?' ?e) ?\351)
((?' ?i) ?\355)
((?' ?l) ?\345)
((?' ?n) ?\361)
((?' ?o) ?\363)
((?' ?r) ?\340)
((?' ?s) ?\266)
((?' ?u) ?\372)
((?' ?y) ?\375)
((?' ?z) ?\274)
((?' ?') ?\264)
((?' ? ) ?')
((?` ?A) ?\241)
((?` ?C) ?\307)
((?` ?E) ?\312)
((?` ?L) ?\243)
((?` ?S) ?\252)
((?` ?T) ?\336)
((?` ?Z) ?\257)
((?` ?a) ?\261)
((?` ?l) ?\263)
((?` ?c) ?\347)
((?` ?e) ?\352)
((?` ?s) ?\272)
((?` ?t) ?\376)
((?` ?z) ?\277)
((?` ? ) ?`)
((?` ?`) ?\252)
((?` ?.) ?\377)
((?^ ?A) ?\302)
((?^ ?O) ?\324)
((?^ ?a) ?\342)
((?^ ?o) ?\364)
((?^ ? ) ?^)
((?^ ?^) ?^) ; no special code?
((?\" ?A) ?\304)
((?\" ?E) ?\313)
((?\" ?O) ?\326)
((?\" ?U) ?\334)
((?\" ?a) ?\344)
((?\" ?e) ?\353)
((?\" ?o) ?\366)
((?\" ?s) ?\337)
((?\" ?u) ?\374)
((?\" ? ) ?\")
((?\" ?\") ?\250)
((?\~ ?A) ?\303)
((?\~ ?C) ?\310)
((?\~ ?D) ?\317)
((?\~ ?L) ?\245)
((?\~ ?N) ?\322)
((?\~ ?O) ?\325)
((?\~ ?R) ?\330)
((?\~ ?S) ?\251)
((?\~ ?T) ?\253)
((?\~ ?U) ?\333)
((?\~ ?Z) ?\256)
((?\~ ?a) ?\323)
((?\~ ?c) ?\350)
((?\~ ?d) ?\357)
((?\~ ?l) ?\265)
((?\~ ?n) ?\362)
((?\~ ?o) ?\365)
((?\~ ?r) ?\370)
((?\~ ?s) ?\271)
((?\~ ?t) ?\273)
((?\~ ?u) ?\373)
((?\~ ?z) ?\276)
((?\~ ?\ ) ?\~)
((?\~ ?v) ?\242) ;; v accent
((?\~ ?\~) ?\242) ;; v accent
((?\~ ?\.) ?\270) ;; cedilla accent
)
"Association list for ISO latin-2 accent combinations.")
(defvar iso-accents-enable '(?' ?` ?^ ?\" ?~)
"*List of accent keys that become prefixes in ISO Accents mode.
The default is (?' ?` ?^ ?\" ?~), which contains all the supported
accent keys. For certain languages, you might want to remove some of
those characters that are not actually used.")
(require 'iso-acc)
;;; iso02-acc.el ends here

2996
lisp/message.el
View file

File diff suppressed because it is too large Load diff

240
lisp/mldrag.el
View file

@ -1,240 +0,0 @@
;;; mldrag.el --- mode line and vertical line dragging to resize windows
;; Copyright (C) 1994 Free Software Foundation, Inc.
;; Author: Kyle E. Jones <kyle@wonderworks.com>
;; Keywords: mouse
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This package lets you drag the modeline, vertical bar and
;; scrollbar to resize windows. Suggested bindings are:
;;
;; (global-set-key [mode-line down-mouse-1] 'mldrag-drag-mode-line)
;; (global-set-key [vertical-line down-mouse-1] 'mldrag-drag-vertical-line)
;; (global-set-key [vertical-scroll-bar S-down-mouse-1]
;; 'mldrag-drag-vertical-line)
;;
;; Put the bindings and (require 'mldrag) in your .emacs file.
;;; Code:
(provide 'mldrag)
(defun mldrag-drag-mode-line (start-event)
"Change the height of the current window with the mouse.
This command should be bound to a down-mouse- event, and is most
usefully bound with the `mode-line' prefix. Holding down a mouse
button and moving the mouse up and down will make the clicked-on
window taller or shorter."
(interactive "e")
(let ((done nil)
(echo-keystrokes 0)
(start-event-frame (window-frame (car (car (cdr start-event)))))
(start-event-window (car (car (cdr start-event))))
(start-nwindows (count-windows t))
(old-selected-window (selected-window))
should-enlarge-minibuffer
event mouse minibuffer y top bot edges wconfig params growth)
(setq params (frame-parameters))
(if (and (not (setq minibuffer (cdr (assq 'minibuffer params))))
(one-window-p t))
(error "Attempt to resize sole window"))
(unwind-protect
(track-mouse
(progn
;; enlarge-window only works on the selected window, so
;; we must select the window where the start event originated.
;; unwind-protect will restore the old selected window later.
(select-window start-event-window)
;; if this is the bottommost ordinary window, then to
;; move its modeline the minibuffer must be enlarged.
(setq should-enlarge-minibuffer
(and minibuffer
(not (one-window-p t))
(= (nth 1 (window-edges minibuffer))
(nth 3 (window-edges)))))
;; loop reading events and sampling the position of
;; the mouse.
(while (not done)
(setq event (read-event)
mouse (mouse-position))
;; do nothing if
;; - there is a switch-frame event.
;; - the mouse isn't in the frame that we started in
;; - the mouse isn't in any Emacs frame
;; drag if
;; - there is a mouse-movement event
;; - there is a scroll-bar-movement event
;; (same as mouse movement for our purposes)
;; quit if
;; - there is a keyboard event or some other unknown event
;; unknown event.
(cond ((integerp event)
(setq done t))
((eq (car event) 'switch-frame)
nil)
((not (memq (car event)
'(mouse-movement scroll-bar-movement)))
(setq done t))
((not (eq (car mouse) start-event-frame))
nil)
((null (car (cdr mouse)))
nil)
(t
(setq y (cdr (cdr mouse))
edges (window-edges)
top (nth 1 edges)
bot (nth 3 edges))
;; scale back a move that would make the
;; window too short.
(cond ((< (- y top -1) window-min-height)
(setq y (+ top window-min-height -1))))
;; compute size change needed
(setq growth (- y bot -1)
wconfig (current-window-configuration))
;; grow/shrink minibuffer?
(if should-enlarge-minibuffer
(progn
;; yes. briefly select minibuffer so
;; enlarge-window will affect the
;; correct window.
(select-window minibuffer)
;; scale back shrinkage if it would
;; make the minibuffer less than 1
;; line tall.
(if (and (> growth 0)
(< (- (window-height minibuffer)
growth)
1))
(setq growth (1- (window-height minibuffer))))
(enlarge-window (- growth))
(select-window start-event-window))
;; no. grow/shrink the selected window
(enlarge-window growth))
;; if this window's growth caused another
;; window to be deleted because it was too
;; short, rescind the change.
;;
;; if size change caused space to be stolen
;; from a window above this one, rescind the
;; change, but only if we didn't grow/srhink
;; the minibuffer. minibuffer size changes
;; can cause all windows to shrink... no way
;; around it.
(if (or (/= start-nwindows (count-windows t))
(and (not should-enlarge-minibuffer)
(/= top (nth 1 (window-edges)))))
(set-window-configuration wconfig)))))))
;; restore the old selected window
(select-window old-selected-window))))
(defun mldrag-drag-vertical-line (start-event)
"Change the width of the current window with the mouse.
This command should be bound to a down-mouse- event, and is most
usefully bound with the `vertical-line' or the `vertical-scroll-bar'
prefix. Holding down a mouse button and moving the mouse left and
right will make the clicked-on window thinner or wider."
(interactive "e")
(let* ((done nil)
(echo-keystrokes 0)
(start-event-frame (window-frame (car (car (cdr start-event)))))
(scroll-bar-left
(eq (cdr (assq 'vertical-scroll-bars (frame-parameters))) 'left))
(start-event-window (car (car (cdr start-event))))
(start-nwindows (count-windows t))
(old-selected-window (selected-window))
event mouse x left right edges wconfig growth)
(if (one-window-p t)
(error "Attempt to resize sole ordinary window"))
(if scroll-bar-left
(when (= (nth 0 (window-edges start-event-window)) 0)
(error "Attempt to drag leftmost scrollbar"))
(when (>= (nth 2 (window-edges start-event-window))
(frame-width start-event-frame))
(error "Attempt to drag rightmost scrollbar")))
(unwind-protect
(track-mouse
(progn
;; enlarge-window only works on the selected window, so
;; we must select the window where the start event originated.
;; unwind-protect will restore the old selected window later.
(select-window start-event-window)
;; loop reading events and sampling the position of
;; the mouse.
(while (not done)
(setq event (read-event)
mouse (mouse-position))
;; do nothing if
;; - there is a switch-frame event.
;; - the mouse isn't in the frame that we started in
;; - the mouse isn't in any Emacs frame
;; drag if
;; - there is a mouse-movement event
;; - there is a scroll-bar-movement event
;; (same as mouse movement for our purposes)
;; quit if
;; - there is a keyboard event or some other unknown event
;; unknown event.
(cond ((integerp event)
(setq done t))
((eq (car event) 'switch-frame)
nil)
((not (memq (car event)
'(mouse-movement scroll-bar-movement)))
(setq done t))
((not (eq (car mouse) start-event-frame))
nil)
((null (car (cdr mouse)))
nil)
(t
(setq x (car (cdr mouse))
edges (window-edges)
left (nth 0 edges)
right (nth 2 edges))
;; scale back a move that would make the
;; window too thin.
(if scroll-bar-left
(cond ((< (- right x) window-min-width)
(setq x (- right window-min-width))))
(cond ((< (- x left -1) window-min-width)
(setq x (+ left window-min-width -1)))))
;; compute size change needed
(setq growth (if scroll-bar-left
(- left x)
(- x right -1))
wconfig (current-window-configuration))
(enlarge-window growth t)
;; if this window's growth caused another
;; window to be deleted because it was too
;; thin, rescind the change.
;;
;; if size change caused space to be stolen
;; from a window to the left of this one,
;; rescind the change.
(if (or (/= start-nwindows (count-windows t))
(if scroll-bar-left
(/= right (nth 2 (window-edges)))
(/= left (nth 0 (window-edges)))))
(set-window-configuration wconfig)))))))
;; restore the old selected window
(select-window old-selected-window))))
;; mldrag.el ends here

625
lisp/nnbabyl.el
View file

@ -1,625 +0,0 @@
;;; nnbabyl.el --- rmail mbox access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; For an overview of what the interface functions do, please see the
;; Gnus sources.
;;; Code:
(require 'nnheader)
(require 'rmail)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnbabyl)
(defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL")
"The name of the rmail box file in the users home directory.")
(defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active")
"The name of the active file for the rmail box.")
(defvoo nnbabyl-get-new-mail t
"If non-nil, nnbabyl will check the incoming mail file and split the mail.")
(defvoo nnbabyl-prepare-save-mail-hook nil
"Hook run narrowed to an article before saving.")
(defvar nnbabyl-mail-delimiter "\^_")
(defconst nnbabyl-version "nnbabyl 1.0"
"nnbabyl version.")
(defvoo nnbabyl-mbox-buffer nil)
(defvoo nnbabyl-current-group nil)
(defvoo nnbabyl-status-string "")
(defvoo nnbabyl-group-alist nil)
(defvoo nnbabyl-active-timestamp nil)
(defvoo nnbabyl-previous-buffer-mode nil)
(eval-and-compile
(autoload 'gnus-set-text-properties "gnus-ems"))
;;; Interface functions
(nnoo-define-basics nnbabyl)
(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((number (length articles))
(count 0)
(delim (concat "^" nnbabyl-mail-delimiter))
article art-string start stop)
(nnbabyl-possibly-change-newsgroup group server)
(while (setq article (pop articles))
(setq art-string (nnbabyl-article-string article))
(set-buffer nnbabyl-mbox-buffer)
(beginning-of-line)
(when (or (search-forward art-string nil t)
(search-backward art-string nil t))
(re-search-backward delim nil t)
(while (and (not (looking-at ".+:"))
(zerop (forward-line 1))))
(setq start (point))
(search-forward "\n\n" nil t)
(setq stop (1- (point)))
(set-buffer nntp-server-buffer)
(insert "221 ")
(princ article (current-buffer))
(insert " Article retrieved.\n")
(insert-buffer-substring nnbabyl-mbox-buffer start stop)
(goto-char (point-max))
(insert ".\n"))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(zerop (% (incf count) 20))
(nnheader-message 5 "nnbabyl: Receiving headers... %d%%"
(/ (* count 100) number))))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(nnheader-message 5 "nnbabyl: Receiving headers...done"))
(set-buffer nntp-server-buffer)
(nnheader-fold-continuation-lines)
'headers)))
(deffoo nnbabyl-open-server (server &optional defs)
(nnoo-change-server 'nnbabyl server defs)
(cond
((not (file-exists-p nnbabyl-mbox-file))
(nnbabyl-close-server)
(nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
((file-directory-p nnbabyl-mbox-file)
(nnbabyl-close-server)
(nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file))
(t
(nnheader-report 'nnbabyl "Opened server %s using mbox %s" server
nnbabyl-mbox-file)
t)))
(deffoo nnbabyl-close-server (&optional server)
;; Restore buffer mode.
(when (and (nnbabyl-server-opened)
nnbabyl-previous-buffer-mode)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(narrow-to-region
(caar nnbabyl-previous-buffer-mode)
(cdar nnbabyl-previous-buffer-mode))
(funcall (cdr nnbabyl-previous-buffer-mode))))
(nnoo-close-server 'nnbabyl server)
(setq nnbabyl-mbox-buffer nil)
t)
(deffoo nnbabyl-server-opened (&optional server)
(and (nnoo-current-server-p 'nnbabyl server)
nnbabyl-mbox-buffer
(buffer-name nnbabyl-mbox-buffer)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(deffoo nnbabyl-request-article (article &optional newsgroup server buffer)
(nnbabyl-possibly-change-newsgroup newsgroup server)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
(when (search-forward (nnbabyl-article-string article) nil t)
(let (start stop summary-line)
(re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
(while (and (not (looking-at ".+:"))
(zerop (forward-line 1))))
(setq start (point))
(or (and (re-search-forward
(concat "^" nnbabyl-mail-delimiter) nil t)
(forward-line -1))
(goto-char (point-max)))
(setq stop (point))
(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring nnbabyl-mbox-buffer start stop)
(goto-char (point-min))
;; If there is an EOOH header, then we have to remove some
;; duplicated headers.
(setq summary-line (looking-at "Summary-line:"))
(when (search-forward "\n*** EOOH ***" nil t)
(if summary-line
;; The headers to be deleted are located before the
;; EOOH line...
(delete-region (point-min) (progn (forward-line 1)
(point)))
;; ...or after.
(delete-region (progn (beginning-of-line) (point))
(or (search-forward "\n\n" nil t)
(point)))))
(if (numberp article)
(cons nnbabyl-current-group article)
(nnbabyl-article-group-number)))))))
(deffoo nnbabyl-request-group (group &optional server dont-check)
(let ((active (cadr (assoc group nnbabyl-group-alist))))
(save-excursion
(cond
((or (null active)
(null (nnbabyl-possibly-change-newsgroup group server)))
(nnheader-report 'nnbabyl "No such group: %s" group))
(dont-check
(nnheader-report 'nnbabyl "Selected group %s" group)
(nnheader-insert ""))
(t
(nnheader-report 'nnbabyl "Selected group %s" group)
(nnheader-insert "211 %d %d %d %s\n"
(1+ (- (cdr active) (car active)))
(car active) (cdr active) group))))))
(deffoo nnbabyl-request-scan (&optional group server)
(nnbabyl-read-mbox)
(nnmail-get-new-mail
'nnbabyl
(lambda ()
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(save-buffer)))
nnbabyl-mbox-file group
(lambda ()
(save-excursion
(let ((in-buf (current-buffer)))
(goto-char (point-min))
(while (search-forward "\n\^_\n" nil t)
(delete-char -1))
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-max))
(search-backward "\n\^_" nil t)
(goto-char (match-end 0))
(insert-buffer-substring in-buf)))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
(deffoo nnbabyl-close-group (group &optional server)
t)
(deffoo nnbabyl-request-create-group (group &optional server)
(nnmail-activate 'nnbabyl)
(unless (assoc group nnbabyl-group-alist)
(setq nnbabyl-group-alist (cons (list group (cons 1 0))
nnbabyl-group-alist))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
t)
(deffoo nnbabyl-request-list (&optional server)
(save-excursion
(nnmail-find-file nnbabyl-active-file)
(setq nnbabyl-group-alist (nnmail-get-active))))
(deffoo nnbabyl-request-newgroups (date &optional server)
(nnbabyl-request-list server))
(deffoo nnbabyl-request-list-newsgroups (&optional server)
(nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
(deffoo nnbabyl-request-expire-articles
(articles newsgroup &optional server force)
(nnbabyl-possibly-change-newsgroup newsgroup server)
(let* ((is-old t)
rest)
(nnmail-activate 'nnbabyl)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(gnus-set-text-properties (point-min) (point-max) nil)
(while (and articles is-old)
(goto-char (point-min))
(if (search-forward (nnbabyl-article-string (car articles)) nil t)
(if (setq is-old
(nnmail-expired-article-p
newsgroup
(buffer-substring
(point) (progn (end-of-line) (point))) force))
(progn
(nnheader-message 5 "Deleting article %d in %s..."
(car articles) newsgroup)
(nnbabyl-delete-mail))
(setq rest (cons (car articles) rest))))
(setq articles (cdr articles)))
(save-buffer)
;; Find the lowest active article in this group.
(let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
(goto-char (point-min))
(while (and (not (search-forward
(nnbabyl-article-string (car active)) nil t))
(<= (car active) (cdr active)))
(setcar active (1+ (car active)))
(goto-char (point-min))))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
(nconc rest articles))))
(deffoo nnbabyl-request-move-article
(article group server accept-form &optional last)
(nnbabyl-possibly-change-newsgroup group server)
(let ((buf (get-buffer-create " *nnbabyl move*"))
result)
(and
(nnbabyl-request-article article group server)
(save-excursion
(set-buffer buf)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
(if (re-search-forward
"^X-Gnus-Newsgroup:"
(save-excursion (search-forward "\n\n" nil t) (point)) t)
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
(if (search-forward (nnbabyl-article-string article) nil t)
(nnbabyl-delete-mail))
(and last (save-buffer))))
result))
(deffoo nnbabyl-request-accept-article (group &optional server last)
(nnbabyl-possibly-change-newsgroup group server)
(nnmail-check-syntax)
(let ((buf (current-buffer))
result beg)
(and
(nnmail-activate 'nnbabyl)
(save-excursion
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-line -1)
(save-excursion
(while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
(delete-region (point) (progn (forward-line 1) (point)))))
(let ((nnmail-split-methods
(if (stringp group) (list (list group ""))
nnmail-split-methods)))
(setq result (car (nnbabyl-save-mail))))
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-max))
(search-backward "\n\^_")
(goto-char (match-end 0))
(insert-buffer-substring buf)
(when last
(save-buffer)
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
result))))
(deffoo nnbabyl-request-replace-article (article group buffer)
(nnbabyl-possibly-change-newsgroup group)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
(if (not (search-forward (nnbabyl-article-string article) nil t))
nil
(nnbabyl-delete-mail t t)
(insert-buffer-substring buffer)
(save-buffer)
t)))
(deffoo nnbabyl-request-delete-group (group &optional force server)
(nnbabyl-possibly-change-newsgroup group server)
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
;; Delete all articles in this group.
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
found)
(while (search-forward ident nil t)
(setq found t)
(nnbabyl-delete-mail))
(and found (save-buffer)))))
;; Remove the group from all structures.
(setq nnbabyl-group-alist
(delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
nnbabyl-current-group nil)
;; Save the active file.
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
t)
(deffoo nnbabyl-request-rename-group (group new-name &optional server)
(nnbabyl-possibly-change-newsgroup group server)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
(new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
found)
(while (search-forward ident nil t)
(replace-match new-ident t t)
(setq found t))
(and found (save-buffer))))
(let ((entry (assoc group nnbabyl-group-alist)))
(and entry (setcar entry new-name))
(setq nnbabyl-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
t))
;;; Internal functions.
;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
;; delimiter line.
(defun nnbabyl-delete-mail (&optional force leave-delim)
;; Delete the current X-Gnus-Newsgroup line.
(or force
(delete-region
(progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
;; Beginning of the article.
(save-excursion
(save-restriction
(widen)
(narrow-to-region
(save-excursion
(re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
(if leave-delim (progn (forward-line 1) (point))
(match-beginning 0)))
(progn
(forward-line 1)
(or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
nil t)
(if (and (not (bobp)) leave-delim)
(progn (forward-line -2) (point))
(match-beginning 0)))
(point-max))))
(goto-char (point-min))
;; Only delete the article if no other groups owns it as well.
(if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
(delete-region (point-min) (point-max))))))
(defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
(when (and server
(not (nnbabyl-server-opened server)))
(nnbabyl-open-server server))
(if (or (not nnbabyl-mbox-buffer)
(not (buffer-name nnbabyl-mbox-buffer)))
(save-excursion (nnbabyl-read-mbox)))
(or nnbabyl-group-alist
(nnmail-activate 'nnbabyl))
(if newsgroup
(if (assoc newsgroup nnbabyl-group-alist)
(setq nnbabyl-current-group newsgroup)
(nnheader-report 'nnbabyl "No such group in file"))
t))
(defun nnbabyl-article-string (article)
(if (numberp article)
(concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
(int-to-string article) " ")
(concat "\nMessage-ID: " article)))
(defun nnbabyl-article-group-number ()
(save-excursion
(goto-char (point-min))
(and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
nil t)
(cons (buffer-substring (match-beginning 1) (match-end 1))
(string-to-int
(buffer-substring (match-beginning 2) (match-end 2)))))))
(defun nnbabyl-insert-lines ()
"Insert how many lines and chars there are in the body of the mail."
(let (lines chars)
(save-excursion
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
;; There may be an EOOH line here...
(when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
(search-forward "\n\n" nil t))
(setq chars (- (point-max) (point))
lines (max (- (count-lines (point) (point-max)) 1) 0))
;; Move back to the end of the headers.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-char -1)
(save-excursion
(when (re-search-backward "^Lines: " nil t)
(delete-region (point) (progn (forward-line 1) (point)))))
(insert (format "Lines: %d\n" lines))
chars))))
(defun nnbabyl-save-mail ()
;; Called narrowed to an article.
(let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
(nnbabyl-insert-lines)
(nnmail-insert-xref group-art)
(nnbabyl-insert-newsgroup-line group-art)
(run-hooks 'nnbabyl-prepare-save-mail-hook)
group-art))
(defun nnbabyl-insert-newsgroup-line (group-art)
(save-excursion
(goto-char (point-min))
(while (looking-at "From ")
(replace-match "Mail-from: From " t t)
(forward-line 1))
;; If there is a C-l at the beginning of the narrowed region, this
;; isn't really a "save", but rather a "scan".
(goto-char (point-min))
(or (looking-at "\^L")
(save-excursion
(insert "\^L\n0, unseen,,\n*** EOOH ***\n")
(goto-char (point-max))
(insert "\^_\n")))
(if (search-forward "\n\n" nil t)
(progn
(forward-char -1)
(while group-art
(insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
(caar group-art) (cdar group-art)
(current-time-string)))
(setq group-art (cdr group-art)))))
t))
(defun nnbabyl-active-number (group)
;; Find the next article number in GROUP.
(let ((active (cadr (assoc group nnbabyl-group-alist))))
(if active
(setcdr active (1+ (cdr active)))
;; This group is new, so we create a new entry for it.
;; This might be a bit naughty... creating groups on the drop of
;; a hat, but I don't know...
(setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1)))
nnbabyl-group-alist)))
(cdr active)))
(defun nnbabyl-read-mbox ()
(nnmail-activate 'nnbabyl)
(unless (file-exists-p nnbabyl-mbox-file)
;; Create a new, empty RMAIL mbox file.
(save-excursion
(set-buffer (setq nnbabyl-mbox-buffer
(create-file-buffer nnbabyl-mbox-file)))
(setq buffer-file-name nnbabyl-mbox-file)
(insert "BABYL OPTIONS:\n\n\^_")
(write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
(if (and nnbabyl-mbox-buffer
(buffer-name nnbabyl-mbox-buffer)
(save-excursion
(set-buffer nnbabyl-mbox-buffer)
(= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
() ; This buffer hasn't changed since we read it last. Possibly.
(save-excursion
(let ((delim (concat "^" nnbabyl-mail-delimiter))
(alist nnbabyl-group-alist)
start end number)
(set-buffer (setq nnbabyl-mbox-buffer
(nnheader-find-file-noselect
nnbabyl-mbox-file nil 'raw)))
;; Save previous buffer mode.
(setq nnbabyl-previous-buffer-mode
(cons (cons (point-min) (point-max))
major-mode))
(buffer-disable-undo (current-buffer))
(widen)
(setq buffer-read-only nil)
(fundamental-mode)
;; Go through the group alist and compare against
;; the rmail file.
(while alist
(goto-char (point-max))
(when (and (re-search-backward
(format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
(caar alist)) nil t)
(> (setq number
(string-to-number
(buffer-substring
(match-beginning 1) (match-end 1))))
(cdadar alist)))
(setcdr (cadar alist) (1+ number)))
(setq alist (cdr alist)))
;; We go through the mbox and make sure that each and
;; every mail belongs to some group or other.
(goto-char (point-min))
(re-search-forward delim nil t)
(setq start (match-end 0))
(while (re-search-forward delim nil t)
(setq end (match-end 0))
(unless (search-backward "\nX-Gnus-Newsgroup: " start t)
(goto-char end)
(save-excursion
(save-restriction
(narrow-to-region (goto-char start) end)
(nnbabyl-save-mail)
(setq end (point-max)))))
(goto-char (setq start end)))
(when (buffer-modified-p (current-buffer))
(save-buffer))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
(defun nnbabyl-remove-incoming-delims ()
(goto-char (point-min))
(while (search-forward "\^_" nil t)
(replace-match "?" t t)))
(defun nnbabyl-check-mbox ()
"Go through the nnbabyl mbox and make sure that no article numbers are reused."
(interactive)
(let ((idents (make-vector 1000 0))
id)
(save-excursion
(when (or (not nnbabyl-mbox-buffer)
(not (buffer-name nnbabyl-mbox-buffer)))
(nnbabyl-read-mbox))
(set-buffer nnbabyl-mbox-buffer)
(goto-char (point-min))
(while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) " nil t)
(if (intern-soft (setq id (match-string 1)) idents)
(progn
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point)))
(nnheader-message 7 "Moving %s..." id)
(nnbabyl-save-mail))
(intern id idents)))
(when (buffer-modified-p (current-buffer))
(save-buffer))
(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
(message ""))))
(provide 'nnbabyl)
;;; nnbabyl.el ends here

229
lisp/nndb.el
View file

@ -1,229 +0,0 @@
;;; nndb.el --- nndb access for Gnus
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; I have shamelessly snarfed the code of nntp.el from sgnus.
;; Kai
;;-
;; Register nndb with known select methods.
(setq gnus-valid-select-methods
(cons '("nndb" mail address respool prompt-address)
gnus-valid-select-methods))
;;; Code:
(require 'nnheader)
(require 'nntp)
(eval-when-compile (require 'cl))
(eval-and-compile
(unless (fboundp 'open-network-stream)
(require 'tcp)))
(eval-when-compile (require 'cl))
(eval-and-compile
(autoload 'news-setup "rnewspost")
(autoload 'news-reply-mode "rnewspost")
(autoload 'cancel-timer "timer")
(autoload 'telnet "telnet" nil t)
(autoload 'telnet-send-input "telnet" nil t)
(autoload 'timezone-parse-date "timezone"))
;; Declare nndb as derived from nntp
(nnoo-declare nndb nntp)
;; Variables specific to nndb
;;- currently not used but just in case...
(defvoo nndb-deliver-program "nndel"
"*The program used to put a message in an NNDB group.")
;; Variables copied from nntp
(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file)
"Like nntp-server-opened-hook."
nntp-server-opened-hook)
;(defvoo nndb-rlogin-parameters '("telnet" "${NNDBSERVER:=localhost}" "9000")
; "*Parameters to nndb-open-login. Like nntp-rlogin-parameters."
; nntp-rlogin-parameters)
;(defvoo nndb-rlogin-user-name nil
; "*User name for rlogin connect method."
; nntp-rlogin-user-name)
(defvoo nndb-address "localhost"
"*The name of the NNDB server."
nntp-address)
(defvoo nndb-port-number 9000
"*Port number to connect to."
nntp-port-number)
;(defvoo nndb-current-group ""
; "Like nntp-current-group."
; nntp-current-group)
(defvoo nndb-status-string nil "" nntp-status-string)
(defconst nndb-version "nndb 0.3"
"Version numbers of this version of NNDB.")
;;; Interface functions.
(nnoo-define-basics nndb)
;; Import other stuff from nntp as is.
(nnoo-import nndb
(nntp))
;;- maybe this should be mail??
;;-(defun nndb-request-type (group &optional article)
;;- 'news)
;;------------------------------------------------------------------
;;- only new stuff below
; nndb-request-update-info does not exist and is not needed
; nndb-request-update-mark does not exist and is not needed
; nndb-request-scan does not exist
; get new mail from somewhere -- maybe this is not needed?
; --> todo
(deffoo nndb-request-create-group (group &optional server)
"Creates a group if it doesn't exist yet."
(nntp-send-command "^[23].*\n" "MKGROUP" group))
; todo -- use some other time than the creation time of the article
; best is time since article has been marked as expirable
(deffoo nndb-request-expire-articles
(articles &optional group server force)
"Expires ARTICLES from GROUP on SERVER.
If FORCE, delete regardless of exiration date, otherwise use normal
expiry mechanism."
(let (msg art)
(nntp-possibly-change-server group server) ;;-
(while articles
(setq art (pop articles))
(nntp-send-command "^\\([23]\\|^423\\).*\n" "DATE" art)
(setq msg (nndb-status-message))
;; CCC we shouldn't be using the variable nndb-status-string?
(if (string-match "^423" (nnheader-get-report 'nndb))
()
(or (string-match "\\([0-9]+\\) \\([0-9]+\\)$" msg)
(error "Not a valid response for DATE command: %s"
msg))
(if (nnmail-expired-article-p
group
(list (string-to-int
(substring msg (match-beginning 1) (match-end 1)))
(string-to-int
(substring msg (match-beginning 2) (match-end 2))))
force)
(nnheader-message 5 "Deleting article %s in %s..."
art group)
(nntp-send-command "^[23].*\n" "DELETE" art))))))
(deffoo nndb-request-move-article
(article group server accept-form &optional last)
"Move ARTICLE (a number) from GROUP on SERVER.
Evals ACCEPT-FORM in current buffer, where the article is.
Optional LAST is ignored."
(let ((artbuf (get-buffer-create " *nndb move*"))
result)
(and
(nndb-request-article article group server artbuf)
(save-excursion
(set-buffer artbuf)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
(nndb-request-expire-articles (list article)
group
server
t))
result))
(deffoo nndb-request-accept-article (group server &optional last)
"The article in the current buffer is put into GROUP."
(nntp-possibly-change-server group server) ;;-
(let (art statmsg)
(when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group)
(nnheader-insert "")
(nntp-encode-text)
(nntp-send-region-to-server (point-min) (point-max))
;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
;; appended to end of the status message.
(nntp-wait-for-response "^[23].*\n")
(setq statmsg (nntp-status-message))
(or (string-match "^\\([0-9]+\\)" statmsg)
(error "nndb: %s" statmsg))
(setq art (substring statmsg
(match-beginning 1)
(match-end 1)))
(message "nndb: accepted %s" art)
(list art))))
(deffoo nndb-request-replace-article (article group buffer)
"ARTICLE is the number of the article in GROUP to be replaced
with the contents of the BUFFER."
(set-buffer buffer)
(let (art statmsg)
(when (nntp-send-command "^[23].*\r?\n" "REPLACE" (int-to-string article))
(nnheader-insert "")
(nntp-encode-text)
(nntp-send-region-to-server (point-min) (point-max))
;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
;; appended to end of the status message.
(nntp-wait-for-response "^[23].*\n")
; (setq statmsg (nntp-status-message))
; (or (string-match "^\\([0-9]+\\)" statmsg)
; (error "nndb: %s" statmsg))
; (setq art (substring statmsg
; (match-beginning 1)
; (match-end 1)))
; (message "nndb: replaced %s" art)
(list (int-to-string article)))))
; nndb-request-delete-group does not exist
; todo -- maybe later
; nndb-request-rename-group does not exist
; todo -- maybe later
(provide 'nndb)

99
lisp/nndir.el
View file

@ -1,99 +0,0 @@
;;; nndir.el --- single directory newsgroup access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'nnheader)
(require 'nnmh)
(require 'nnml)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nndir
nnml nnmh)
(defvoo nndir-directory nil
"Where nndir will look for groups."
nnml-current-directory nnmh-current-directory)
(defvoo nndir-nov-is-evil nil
"*Non-nil means that nndir will never retrieve NOV headers."
nnml-nov-is-evil)
(defvoo nndir-current-group "" nil nnml-current-group nnmh-current-group)
(defvoo nndir-top-directory nil nil nnml-directory nnmh-directory)
(defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail)
(defvoo nndir-status-string "" nil nnmh-status-string)
(defconst nndir-version "nndir 1.0")
;;; Interface functions.
(nnoo-define-basics nndir)
(deffoo nndir-open-server (server &optional defs)
(setq nndir-directory
(or (cadr (assq 'nndir-directory defs))
server))
(unless (assq 'nndir-directory defs)
(push `(nndir-directory ,server) defs))
(push `(nndir-current-group
,(file-name-nondirectory (directory-file-name nndir-directory)))
defs)
(push `(nndir-top-directory
,(file-name-directory (directory-file-name nndir-directory)))
defs)
(nnoo-change-server 'nndir server defs)
(let (err)
(cond
((not (condition-case arg
(file-exists-p nndir-directory)
(ftp-error (setq err (format "%s" arg)))))
(nndir-close-server)
(nnheader-report
'nndir (or err "No such file or directory: %s" nndir-directory)))
((not (file-directory-p (file-truename nndir-directory)))
(nndir-close-server)
(nnheader-report 'nndir "Not a directory: %s" nndir-directory))
(t
(nnheader-report 'nndir "Opened server %s using directory %s"
server nndir-directory)
t))))
(nnoo-map-functions nndir
(nnml-retrieve-headers 0 nndir-current-group 0 0)
(nnmh-request-article 0 nndir-current-group 0 0)
(nnmh-request-group nndir-current-group 0 0)
(nnmh-close-group nndir-current-group 0)
(nnmh-request-list (nnoo-current-server 'nndir) nndir-directory)
(nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory))
(provide 'nndir)
;;; nndir.el ends here

482
lisp/nndoc.el
View file

@ -1,482 +0,0 @@
;;; nndoc.el --- single file access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'nnheader)
(require 'message)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nndoc)
(defvoo nndoc-article-type 'guess
"*Type of the file.
One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
`mime-digest', `standard-digest', `slack-digest', `clari-briefs' or
`guess'.")
(defvoo nndoc-post-type 'mail
"*Whether the nndoc group is `mail' or `post'.")
(defvar nndoc-type-alist
`((mmdf
(article-begin . "^\^A\^A\^A\^A\n")
(body-end . "^\^A\^A\^A\^A\n"))
(news
(article-begin . "^Path:"))
(rnews
(article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
(body-end-function . nndoc-rnews-body-end))
(mbox
(article-begin . "^From \\([^ \n]*\\(\\|\".*\"[^ \n]*\\)\\) ?\\([^ \n]*\\) *\\([^ ]*\\) *\\([0-9]*\\) *\\([0-9:]*\\) *\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?\\|[-+]?[0-9][0-9][0-9][0-9]\\|\\) * [0-9][0-9]\\([0-9]*\\) *\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?\\|[-+]?[0-9][0-9][0-9][0-9]\\|\\) *\\(remote from .*\\)?\n")
(article-begin-function . nndoc-mbox-article-begin)
(body-end-function . nndoc-mbox-body-end))
(babyl
(article-begin . "\^_\^L *\n")
(body-end . "\^_")
(body-begin-function . nndoc-babyl-body-begin)
(head-begin-function . nndoc-babyl-head-begin))
(forward
(article-begin . "^-+ Start of forwarded message -+\n+")
(body-end . "^-+ End of forwarded message -+$")
(prepare-body . nndoc-unquote-dashes))
(clari-briefs
(article-begin . "^ \\*")
(body-end . "^\t------*[ \t]^*\n^ \\*")
(body-begin . "^\t")
(head-end . "^\t")
(generate-head . nndoc-generate-clari-briefs-head)
(article-transform . nndoc-transform-clari-briefs))
(slack-digest
(article-begin . "^------------------------------*[\n \t]+")
(head-end . "^ ?$")
(body-end-function . nndoc-digest-body-end)
(body-begin . "^ ?$")
(file-end . "^End of")
(prepare-body . nndoc-unquote-dashes))
(mime-digest
(article-begin . "")
(head-end . "^ ?$")
(body-end . "")
(file-end . ""))
(standard-digest
(first-article . ,(concat "^" (make-string 70 ?-) "\n\n+"))
(article-begin . ,(concat "\n\n" (make-string 30 ?-) "\n\n+"))
(prepare-body . nndoc-unquote-dashes)
(body-end-function . nndoc-digest-body-end)
(head-end . "^ ?$")
(body-begin . "^ ?\n")
(file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$"))
(guess
(guess . nndoc-guess-type))
(digest
(guess . nndoc-guess-digest-type))
))
(defvoo nndoc-file-begin nil)
(defvoo nndoc-first-article nil)
(defvoo nndoc-article-end nil)
(defvoo nndoc-article-begin nil)
(defvoo nndoc-article-begin-function nil)
(defvoo nndoc-head-begin nil)
(defvoo nndoc-head-end nil)
(defvoo nndoc-file-end nil)
(defvoo nndoc-body-begin nil)
(defvoo nndoc-body-end-function nil)
(defvoo nndoc-body-begin-function nil)
(defvoo nndoc-head-begin-function nil)
(defvoo nndoc-body-end nil)
(defvoo nndoc-dissection-alist nil)
(defvoo nndoc-prepare-body nil)
(defvoo nndoc-generate-head nil)
(defvoo nndoc-article-transform nil)
(defvoo nndoc-status-string "")
(defvoo nndoc-group-alist nil)
(defvoo nndoc-current-buffer nil
"Current nndoc news buffer.")
(defvoo nndoc-address nil)
(defconst nndoc-version "nndoc 1.0"
"nndoc version.")
;;; Interface functions
(nnoo-define-basics nndoc)
(deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
(when (nndoc-possibly-change-buffer newsgroup server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let (article entry)
(if (stringp (car articles))
'headers
(while articles
(when (setq entry (cdr (assq (setq article (pop articles))
nndoc-dissection-alist)))
(insert (format "221 %d Article retrieved.\n" article))
(if nndoc-generate-head
(funcall nndoc-generate-head article)
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry)))
(goto-char (point-max))
(or (= (char-after (1- (point))) ?\n) (insert "\n"))
(insert (format "Lines: %d\n" (nth 4 entry)))
(insert ".\n")))
(nnheader-fold-continuation-lines)
'headers)))))
(deffoo nndoc-request-article (article &optional newsgroup server buffer)
(nndoc-possibly-change-buffer newsgroup server)
(save-excursion
(let ((buffer (or buffer nntp-server-buffer))
(entry (cdr (assq article nndoc-dissection-alist)))
beg)
(set-buffer buffer)
(erase-buffer)
(if (stringp article)
nil
(insert-buffer-substring
nndoc-current-buffer (car entry) (nth 1 entry))
(insert "\n")
(setq beg (point))
(insert-buffer-substring
nndoc-current-buffer (nth 2 entry) (nth 3 entry))
(goto-char beg)
(when nndoc-prepare-body
(funcall nndoc-prepare-body))
(when nndoc-article-transform
(funcall nndoc-article-transform article))
t))))
(deffoo nndoc-request-group (group &optional server dont-check)
"Select news GROUP."
(let (number)
(cond
((not (nndoc-possibly-change-buffer group server))
(nnheader-report 'nndoc "No such file or buffer: %s"
nndoc-address))
(dont-check
(nnheader-report 'nndoc "Selected group %s" group)
t)
((zerop (setq number (length nndoc-dissection-alist)))
(nndoc-close-group group)
(nnheader-report 'nndoc "No articles in group %s" group))
(t
(nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
(deffoo nndoc-request-type (group &optional article)
(cond ((not article) 'unknown)
(nndoc-post-type nndoc-post-type)
(t 'unknown)))
(deffoo nndoc-close-group (group &optional server)
(nndoc-possibly-change-buffer group server)
(and nndoc-current-buffer
(buffer-name nndoc-current-buffer)
(kill-buffer nndoc-current-buffer))
(setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
nndoc-group-alist))
(setq nndoc-current-buffer nil)
(nnoo-close-server 'nndoc server)
(setq nndoc-dissection-alist nil)
t)
(deffoo nndoc-request-list (&optional server)
nil)
(deffoo nndoc-request-newgroups (date &optional server)
nil)
(deffoo nndoc-request-list-newsgroups (&optional server)
nil)
;;; Internal functions.
(defun nndoc-possibly-change-buffer (group source)
(let (buf)
(cond
;; The current buffer is this group's buffer.
((and nndoc-current-buffer
(buffer-name nndoc-current-buffer)
(eq nndoc-current-buffer
(setq buf (cdr (assoc group nndoc-group-alist))))))
;; We change buffers by taking an old from the group alist.
;; `source' is either a string (a file name) or a buffer object.
(buf
(setq nndoc-current-buffer buf))
;; It's a totally new group.
((or (and (bufferp nndoc-address)
(buffer-name nndoc-address))
(and (stringp nndoc-address)
(file-exists-p nndoc-address)
(not (file-directory-p nndoc-address))))
(push (cons group (setq nndoc-current-buffer
(get-buffer-create
(concat " *nndoc " group "*"))))
nndoc-group-alist)
(setq nndoc-dissection-alist nil)
(save-excursion
(set-buffer nndoc-current-buffer)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(if (stringp nndoc-address)
(insert-file-contents nndoc-address)
(insert-buffer-substring nndoc-address)))))
;; Initialize the nndoc structures according to this new document.
(when (and nndoc-current-buffer
(not nndoc-dissection-alist))
(save-excursion
(set-buffer nndoc-current-buffer)
(nndoc-set-delims)
(nndoc-dissect-buffer)))
(unless nndoc-current-buffer
(nndoc-close-server))
;; Return whether we managed to select a file.
nndoc-current-buffer))
;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
(defun nndoc-guess-digest-type ()
"Guess what digest type the current document is."
(let ((case-fold-search t) ; We match a bit too much, keep it simple.
boundary-id b-delimiter entry)
(goto-char (point-min))
(cond
;; MIME digest.
((and
(re-search-forward
(concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
"boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
nil t)
(match-beginning 1))
(setq boundary-id (match-string 1)
b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
(setq entry (assq 'mime-digest nndoc-type-alist))
(setcdr entry
(list
(cons 'head-end "^ ?$")
(cons 'body-begin "^ ?\n")
(cons 'article-begin b-delimiter)
(cons 'body-end-function 'nndoc-digest-body-end)
; (cons 'body-end
; (concat "\n--" boundary-id "\\(--\\)?[\n \t]+"))
(cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
'mime-digest)
;; Standard digest.
((and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
(re-search-forward
(concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
'standard-digest)
;; Stupid digest.
(t
'slack-digest))))
(defun nndoc-guess-type ()
"Guess what document type is in the current buffer."
(goto-char (point-min))
(cond
((looking-at message-unix-mail-delimiter)
'mbox)
((looking-at "\^A\^A\^A\^A$")
'mmdf)
((looking-at "^Path:.*\n")
'news)
((looking-at "#! *rnews")
'rnews)
((re-search-forward "\^_\^L *\n" nil t)
'babyl)
((save-excursion
(and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
(not (re-search-forward "^Subject:.*digest" nil t))))
'forward)
((let ((case-fold-search nil))
(re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
'clari-briefs)
(t
'digest)))
(defun nndoc-set-delims ()
"Set the nndoc delimiter variables according to the type of the document."
(let ((vars '(nndoc-file-begin
nndoc-first-article
nndoc-article-end nndoc-head-begin nndoc-head-end
nndoc-file-end nndoc-article-begin
nndoc-body-begin nndoc-body-end-function nndoc-body-end
nndoc-prepare-body nndoc-article-transform
nndoc-generate-head nndoc-body-begin-function
nndoc-head-begin-function nndoc-article-begin-function)))
(while vars
(set (pop vars) nil)))
(let* (defs guess)
;; Guess away until we find the real file type.
(while (setq defs (cdr (assq nndoc-article-type nndoc-type-alist))
guess (assq 'guess defs))
(setq nndoc-article-type (funcall (cdr guess))))
;; Set the nndoc variables.
(while defs
(set (intern (format "nndoc-%s" (caar defs)))
(cdr (pop defs))))))
(defun nndoc-search (regexp)
(prog1
(re-search-forward regexp nil t)
(beginning-of-line)))
(defun nndoc-dissect-buffer ()
"Go through the document and partition it into heads/bodies/articles."
(let ((i 0)
(first t)
head-begin head-end body-begin body-end)
(setq nndoc-dissection-alist nil)
(save-excursion
(set-buffer nndoc-current-buffer)
(goto-char (point-min))
;; Find the beginning of the file.
(when nndoc-file-begin
(nndoc-search nndoc-file-begin))
;; Go through the file.
(while (if (and first nndoc-first-article)
(nndoc-search nndoc-first-article)
(if nndoc-article-begin-function
(funcall nndoc-article-begin-function)
(nndoc-search nndoc-article-begin)))
(setq first nil)
(cond (nndoc-head-begin-function
(funcall nndoc-head-begin-function))
(nndoc-head-begin
(nndoc-search nndoc-head-begin)))
(if (and nndoc-file-end
(looking-at nndoc-file-end))
(goto-char (point-max))
(setq head-begin (point))
(nndoc-search (or nndoc-head-end "^$"))
(setq head-end (point))
(if nndoc-body-begin-function
(funcall nndoc-body-begin-function)
(nndoc-search (or nndoc-body-begin "^\n")))
(setq body-begin (point))
(or (and nndoc-body-end-function
(funcall nndoc-body-end-function))
(and nndoc-body-end
(nndoc-search nndoc-body-end))
(if nndoc-article-begin-function
(funcall nndoc-article-begin-function)
(nndoc-search nndoc-article-begin))
(progn
(goto-char (point-max))
(when nndoc-file-end
(and (re-search-backward nndoc-file-end nil t)
(beginning-of-line)))))
(setq body-end (point))
(push (list (incf i) head-begin head-end body-begin body-end
(count-lines body-begin body-end))
nndoc-dissection-alist))))))
(defun nndoc-unquote-dashes ()
"Unquote quoted non-separators in digests."
(while (re-search-forward "^- -"nil t)
(replace-match "-" t t)))
(defun nndoc-digest-body-end ()
(and (re-search-forward nndoc-article-begin nil t)
(goto-char (match-beginning 0))))
(defun nndoc-mbox-article-begin ()
(when (re-search-forward nndoc-article-begin nil t)
(goto-char (match-beginning 0))))
(defun nndoc-mbox-body-end ()
(let ((beg (point))
len end)
(when
(save-excursion
(and (re-search-backward nndoc-article-begin nil t)
(setq end (point))
(search-forward "\n\n" beg t)
(re-search-backward
"^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
(setq len (string-to-int (match-string 1)))
(search-forward "\n\n" beg t)
(or (= (setq len (+ (point) len)) (point-max))
(and (< len (point-max))
(goto-char len)
(looking-at nndoc-article-begin)))))
(goto-char len))))
(defun nndoc-rnews-body-end ()
(and (re-search-backward nndoc-article-begin nil t)
(forward-line 1)
(goto-char (+ (point) (string-to-int (match-string 1))))))
(defun nndoc-transform-clari-briefs (article)
(goto-char (point-min))
(when (looking-at " *\\*\\(.*\\)\n")
(replace-match "" t t))
(nndoc-generate-clari-briefs-head article))
(defun nndoc-generate-clari-briefs-head (article)
(let ((entry (cdr (assq article nndoc-dissection-alist)))
subject from)
(save-excursion
(set-buffer nndoc-current-buffer)
(save-restriction
(narrow-to-region (car entry) (nth 3 entry))
(goto-char (point-min))
(when (looking-at " *\\*\\(.*\\)$")
(setq subject (match-string 1))
(when (string-match "[ \t]+$" subject)
(setq subject (substring subject 0 (match-beginning 0)))))
(when
(let ((case-fold-search nil))
(re-search-forward
"^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
(setq from (match-string 1)))))
(insert "From: " "clari@clari.net (" (or from "unknown") ")"
"\nSubject: " (or subject "(no subject)") "\n")))
(defun nndoc-babyl-body-begin ()
(re-search-forward "^\n" nil t)
(when (looking-at "\*\*\* EOOH \*\*\*")
(re-search-forward "^\n" nil t)))
(defun nndoc-babyl-head-begin ()
(when (re-search-forward "^[0-9].*\n" nil t)
(when (looking-at "\*\*\* EOOH \*\*\*")
(forward-line 1))
t))
(provide 'nndoc)
;;; nndoc.el ends here

356
lisp/nneething.el
View file

@ -1,356 +0,0 @@
;;; nneething.el --- random file access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
;; For an overview of what the interface functions do, please see the
;; Gnus sources.
;;; Code:
(require 'nnheader)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nneething)
(defvoo nneething-map-file-directory "~/.nneething/"
"*Where nneething stores the map files.")
(defvoo nneething-map-file ".nneething"
"*Name of the map files.")
(defvoo nneething-exclude-files nil
"*Regexp saying what files to exclude from the group.
If this variable is nil, no files will be excluded.")
;;; Internal variables.
(defconst nneething-version "nneething 1.0"
"nneething version.")
(defvoo nneething-current-directory nil
"Current news group directory.")
(defvoo nneething-status-string "")
(defvoo nneething-group-alist nil)
(defvoo nneething-message-id-number 0)
(defvoo nneething-work-buffer " *nneething work*")
(defvoo nneething-directory nil)
(defvoo nneething-group nil)
(defvoo nneething-map nil)
(defvoo nneething-read-only nil)
(defvoo nneething-active nil)
;;; Interface functions.
(nnoo-define-basics nneething)
(deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
(nneething-possibly-change-directory group)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let* ((number (length articles))
(count 0)
(large (and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)))
article file)
(if (stringp (car articles))
'headers
(while (setq article (pop articles))
(setq file (nneething-file-name article))
(when (and (file-exists-p file)
(or (file-directory-p file)
(not (zerop (nnheader-file-size file)))))
(insert (format "221 %d Article retrieved.\n" article))
(nneething-insert-head file)
(insert ".\n"))
(incf count)
(and large
(zerop (% count 20))
(message "nneething: Receiving headers... %d%%"
(/ (* count 100) number))))
(when large
(message "nneething: Receiving headers...done"))
(nnheader-fold-continuation-lines)
'headers))))
(deffoo nneething-request-article (id &optional group server buffer)
(nneething-possibly-change-directory group)
(let ((file (unless (stringp id) (nneething-file-name id)))
(nntp-server-buffer (or buffer nntp-server-buffer)))
(and (stringp file) ; We did not request by Message-ID.
(file-exists-p file) ; The file exists.
(not (file-directory-p file)) ; It's not a dir.
(save-excursion
(nnmail-find-file file) ; Insert the file in the nntp buf.
(or (nnheader-article-p) ; Either it's a real article...
(progn
(goto-char (point-min))
(nneething-make-head file (current-buffer)) ; ... or we fake some headers.
(insert "\n")))
t))))
(deffoo nneething-request-group (group &optional dir dont-check)
(nneething-possibly-change-directory group dir)
(unless dont-check
(nneething-create-mapping)
(if (> (car nneething-active) (cdr nneething-active))
(nnheader-insert "211 0 1 0 %s\n" group)
(nnheader-insert
"211 %d %d %d %s\n"
(- (1+ (cdr nneething-active)) (car nneething-active))
(car nneething-active) (cdr nneething-active)
group)))
t)
(deffoo nneething-request-list (&optional server dir)
(nnheader-report 'nneething "LIST is not implemented."))
(deffoo nneething-request-newgroups (date &optional server)
(nnheader-report 'nneething "NEWSGROUPS is not implemented."))
(deffoo nneething-request-type (group &optional article)
'unknown)
(deffoo nneething-close-group (group &optional server)
(setq nneething-current-directory nil)
t)
;;; Internal functions.
(defun nneething-possibly-change-directory (group &optional dir)
(when group
(if (and nneething-group
(string= group nneething-group))
t
(let (entry)
(if (setq entry (assoc group nneething-group-alist))
(progn
(setq nneething-group group)
(setq nneething-directory (nth 1 entry))
(setq nneething-map (nth 2 entry))
(setq nneething-active (nth 3 entry)))
(setq nneething-group group)
(setq nneething-directory dir)
(setq nneething-map nil)
(setq nneething-active (cons 1 0))
(nneething-create-mapping)
(push (list group dir nneething-map nneething-active)
nneething-group-alist))))))
(defun nneething-map-file ()
;; We make sure that the .nneething directory exists.
(unless (file-exists-p nneething-map-file-directory)
(make-directory nneething-map-file-directory 'parents))
;; We store it in a special directory under the user's home dir.
(concat (file-name-as-directory nneething-map-file-directory)
nneething-group nneething-map-file))
(defun nneething-create-mapping ()
;; Read nneething-active and nneething-map.
(let ((map-file (nneething-map-file))
(files (directory-files nneething-directory))
touched map-files)
(if (file-exists-p map-file)
(condition-case nil
(load map-file nil t t)
(error nil)))
(or nneething-active (setq nneething-active (cons 1 0)))
;; Old nneething had a different map format.
(when (and (cdar nneething-map)
(atom (cdar nneething-map)))
(setq nneething-map
(mapcar (lambda (n)
(list (cdr n) (car n)
(nth 5 (file-attributes
(nneething-file-name (car n))))))
nneething-map)))
;; Remove files matching the exclusion regexp.
(when nneething-exclude-files
(let ((f files)
prev)
(while f
(if (string-match nneething-exclude-files (car f))
(if prev (setcdr prev (cdr f))
(setq files (cdr files)))
(setq prev f))
(setq f (cdr f)))))
;; Remove deleted files from the map.
(let ((map nneething-map)
prev)
(while map
(if (and (member (cadar map) files)
;; We also remove files that have changed mod times.
(equal (nth 5 (file-attributes
(nneething-file-name (cadar map))))
(caddar map)))
(progn
(push (cadar map) map-files)
(setq prev map))
(setq touched t)
(if prev
(setcdr prev (cdr map))
(setq nneething-map (cdr nneething-map))))
(setq map (cdr map))))
;; Find all new files and enter them into the map.
(while files
(unless (member (car files) map-files)
;; This file is not in the map, so we enter it.
(setq touched t)
(setcdr nneething-active (1+ (cdr nneething-active)))
(push (list (cdr nneething-active) (car files)
(nth 5 (file-attributes
(nneething-file-name (car files)))))
nneething-map))
(setq files (cdr files)))
(when (and touched
(not nneething-read-only))
(save-excursion
(nnheader-set-temp-buffer " *nneething map*")
(insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
"(setq nneething-active '" (prin1-to-string nneething-active)
")\n")
(write-region (point-min) (point-max) map-file nil 'nomesg)
(kill-buffer (current-buffer))))))
(defun nneething-insert-head (file)
"Insert the head of FILE."
(when (nneething-get-head file)
(insert-buffer-substring nneething-work-buffer)
(goto-char (point-max))))
(defun nneething-make-head (file &optional buffer)
"Create a head by looking at the file attributes of FILE."
(let ((atts (file-attributes file)))
(insert
"Subject: " (file-name-nondirectory file) "\n"
"Message-ID: <nneething-"
(int-to-string (incf nneething-message-id-number))
"@" (system-name) ">\n"
(if (equal '(0 0) (nth 5 atts)) ""
(concat "Date: " (current-time-string (nth 5 atts)) "\n"))
(or (if buffer
(save-excursion
(set-buffer buffer)
(if (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
(concat "From: " (match-string 0) "\n"))))
(nneething-from-line (nth 2 atts) file))
(if (> (string-to-int (int-to-string (nth 7 atts))) 0)
(concat "Chars: " (int-to-string (nth 7 atts)) "\n")
"")
(if buffer
(save-excursion
(set-buffer buffer)
(concat "Lines: " (int-to-string
(count-lines (point-min) (point-max))) "\n"))
"")
)))
(defun nneething-from-line (uid &optional file)
"Return a From header based of UID."
(let* ((login (condition-case nil
(user-login-name uid)
(error
(cond ((= uid (user-uid)) (user-login-name))
((zerop uid) "root")
(t (int-to-string uid))))))
(name (condition-case nil
(user-full-name uid)
(error
(cond ((= uid (user-uid)) (user-full-name))
((zerop uid) "Ms. Root")))))
(host (if (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
(prog1
(substring file
(match-beginning 1)
(match-end 1))
(if (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
(setq login (substring file
(match-beginning 2)
(match-end 2))
name nil)))
(system-name))))
(concat "From: " login "@" host
(if name (concat " (" name ")") "") "\n")))
(defun nneething-get-head (file)
"Either find the head in FILE or make a head for FILE."
(save-excursion
(set-buffer (get-buffer-create nneething-work-buffer))
(setq case-fold-search nil)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(cond
((not (file-exists-p file))
;; The file do not exist.
nil)
((or (file-directory-p file)
(file-symlink-p file))
;; It's a dir, so we fudge a head.
(nneething-make-head file) t)
(t
;; We examine the file.
(nnheader-insert-head file)
(if (nnheader-article-p)
(delete-region
(progn
(goto-char (point-min))
(or (and (search-forward "\n\n" nil t)
(1- (point)))
(point-max)))
(point-max))
(goto-char (point-min))
(nneething-make-head file (current-buffer))
(delete-region (point) (point-max)))
t))))
(defun nneething-file-name (article)
"Return the file name of ARTICLE."
(concat (file-name-as-directory nneething-directory)
(if (numberp article)
(cadr (assq article nneething-map))
article)))
(provide 'nneething)
;;; nneething.el ends here

784
lisp/nnfolder.el
View file

@ -1,784 +0,0 @@
;;; nnfolder.el --- mail folder access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Scott Byer <byer@mv.us.adobe.com>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; For an overview of what the interface functions do, please see the
;; Gnus sources.
;; Various enhancements by byer@mv.us.adobe.com (Scott Byer).
;;; Code:
(require 'nnheader)
(require 'message)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnfolder)
(defvoo nnfolder-directory (expand-file-name message-directory)
"The name of the nnfolder directory.")
(defvoo nnfolder-active-file
(nnheader-concat nnfolder-directory "active")
"The name of the active file.")
;; I renamed this variable to something more in keeping with the general GNU
;; style. -SLB
(defvoo nnfolder-ignore-active-file nil
"If non-nil, causes nnfolder to do some extra work in order to determine
the true active ranges of an mbox file. Note that the active file is still
saved, but its values are not used. This costs some extra time when
scanning an mbox when opening it.")
(defvoo nnfolder-distrust-mbox nil
"If non-nil, causes nnfolder to not trust the user with respect to
inserting unaccounted for mail in the middle of an mbox file. This can greatly
slow down scans, which now must scan the entire file for unmarked messages.
When nil, scans occur forward from the last marked message, a huge
time saver for large mailboxes.")
(defvoo nnfolder-newsgroups-file
(concat (file-name-as-directory nnfolder-directory) "newsgroups")
"Mail newsgroups description file.")
(defvoo nnfolder-get-new-mail t
"If non-nil, nnfolder will check the incoming mail file and split the mail.")
(defvoo nnfolder-prepare-save-mail-hook nil
"Hook run narrowed to an article before saving.")
(defvoo nnfolder-save-buffer-hook nil
"Hook run before saving the nnfolder mbox buffer.")
(defvoo nnfolder-inhibit-expiry nil
"If non-nil, inhibit expiry.")
(defconst nnfolder-version "nnfolder 1.0"
"nnfolder version.")
(defconst nnfolder-article-marker "X-Gnus-Article-Number: "
"String used to demarcate what the article number for a message is.")
(defvoo nnfolder-current-group nil)
(defvoo nnfolder-current-buffer nil)
(defvoo nnfolder-status-string "")
(defvoo nnfolder-group-alist nil)
(defvoo nnfolder-buffer-alist nil)
(defvoo nnfolder-scantime-alist nil)
;;; Interface functions
(nnoo-define-basics nnfolder)
(deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((delim-string (concat "^" message-unix-mail-delimiter))
article art-string start stop)
(nnfolder-possibly-change-group group server)
(when nnfolder-current-buffer
(set-buffer nnfolder-current-buffer)
(goto-char (point-min))
(if (stringp (car articles))
'headers
(while articles
(setq article (car articles))
(setq art-string (nnfolder-article-string article))
(set-buffer nnfolder-current-buffer)
(if (or (search-forward art-string nil t)
;; Don't search the whole file twice! Also, articles
;; probably have some locality by number, so searching
;; backwards will be faster. Especially if we're at the
;; beginning of the buffer :-). -SLB
(search-backward art-string nil t))
(progn
(setq start (or (re-search-backward delim-string nil t)
(point)))
(search-forward "\n\n" nil t)
(setq stop (1- (point)))
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nnfolder-current-buffer start stop)
(goto-char (point-max))
(insert ".\n")))
(setq articles (cdr articles)))
(set-buffer nntp-server-buffer)
(nnheader-fold-continuation-lines)
'headers)))))
(deffoo nnfolder-open-server (server &optional defs)
(nnoo-change-server 'nnfolder server defs)
(when (not (file-exists-p nnfolder-directory))
(condition-case ()
(make-directory nnfolder-directory t)
(error t)))
(cond
((not (file-exists-p nnfolder-directory))
(nnfolder-close-server)
(nnheader-report 'nnfolder "Couldn't create directory: %s"
nnfolder-directory))
((not (file-directory-p (file-truename nnfolder-directory)))
(nnfolder-close-server)
(nnheader-report 'nnfolder "Not a directory: %s" nnfolder-directory))
(t
(nnheader-report 'nnfolder "Opened server %s using directory %s"
server nnfolder-directory)
t)))
(deffoo nnfolder-request-close ()
(let ((alist nnfolder-buffer-alist))
(while alist
(nnfolder-close-group (caar alist) nil t)
(setq alist (cdr alist))))
(nnoo-close-server 'nnfolder)
(setq nnfolder-buffer-alist nil
nnfolder-group-alist nil))
(deffoo nnfolder-request-article (article &optional group server buffer)
(nnfolder-possibly-change-group group server)
(save-excursion
(set-buffer nnfolder-current-buffer)
(goto-char (point-min))
(if (search-forward (nnfolder-article-string article) nil t)
(let (start stop)
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
(setq start (point))
(forward-line 1)
(or (and (re-search-forward
(concat "^" message-unix-mail-delimiter) nil t)
(forward-line -1))
(goto-char (point-max)))
(setq stop (point))
(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring nnfolder-current-buffer start stop)
(goto-char (point-min))
(while (looking-at "From ")
(delete-char 5)
(insert "X-From-Line: ")
(forward-line 1))
(if (numberp article)
(cons nnfolder-current-group article)
(goto-char (point-min))
(search-forward (concat "\n" nnfolder-article-marker))
(cons nnfolder-current-group
(string-to-int
(buffer-substring
(point) (progn (end-of-line) (point)))))))))))
(deffoo nnfolder-request-group (group &optional server dont-check)
(save-excursion
(nnmail-activate 'nnfolder)
(if (not (assoc group nnfolder-group-alist))
(nnheader-report 'nnfolder "No such group: %s" group)
(nnfolder-possibly-change-group group server)
(if dont-check
(progn
(nnheader-report 'nnfolder "Selected group %s" group)
t)
(let* ((active (assoc group nnfolder-group-alist))
(group (car active))
(range (cadr active)))
(cond
((null active)
(nnheader-report 'nnfolder "No such group: %s" group))
((null nnfolder-current-group)
(nnheader-report 'nnfolder "Empty group: %s" group))
(t
(nnheader-report 'nnfolder "Selected group %s" group)
(nnheader-insert "211 %d %d %d %s\n"
(1+ (- (cdr range) (car range)))
(car range) (cdr range) group))))))))
(deffoo nnfolder-request-scan (&optional group server)
(nnfolder-possibly-change-group group server t)
(nnmail-get-new-mail
'nnfolder
(lambda ()
(let ((bufs nnfolder-buffer-alist))
(save-excursion
(while bufs
(if (not (buffer-name (nth 1 (car bufs))))
(setq nnfolder-buffer-alist
(delq (car bufs) nnfolder-buffer-alist))
(set-buffer (nth 1 (car bufs)))
(nnfolder-save-buffer)
(kill-buffer (current-buffer)))
(setq bufs (cdr bufs))))))
nnfolder-directory
group))
;; Don't close the buffer if we're not shutting down the server. This way,
;; we can keep the buffer in the group buffer cache, and not have to grovel
;; over the buffer again unless we add new mail to it or modify it in some
;; way.
(deffoo nnfolder-close-group (group &optional server force)
;; Make sure we _had_ the group open.
(when (or (assoc group nnfolder-buffer-alist)
(equal group nnfolder-current-group))
(let ((inf (assoc group nnfolder-buffer-alist)))
(when inf
(when nnfolder-current-group
(push (list nnfolder-current-group nnfolder-current-buffer)
nnfolder-buffer-alist))
(setq nnfolder-buffer-alist
(delq inf nnfolder-buffer-alist))
(setq nnfolder-current-buffer (cadr inf)
nnfolder-current-group (car inf))))
(when (and nnfolder-current-buffer
(buffer-name nnfolder-current-buffer))
(save-excursion
(set-buffer nnfolder-current-buffer)
;; If the buffer was modified, write the file out now.
(nnfolder-save-buffer)
;; If we're shutting the server down, we need to kill the
;; buffer and remove it from the open buffer list. Or, of
;; course, if we're trying to minimize our space impact.
(kill-buffer (current-buffer))
(setq nnfolder-buffer-alist (delq (assoc group nnfolder-buffer-alist)
nnfolder-buffer-alist)))))
(setq nnfolder-current-group nil
nnfolder-current-buffer nil)
t)
(deffoo nnfolder-request-create-group (group &optional server)
(nnfolder-possibly-change-group nil server)
(nnmail-activate 'nnfolder)
(when group
(unless (assoc group nnfolder-group-alist)
(push (list group (cons 1 0)) nnfolder-group-alist)
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
t)
(deffoo nnfolder-request-list (&optional server)
(nnfolder-possibly-change-group nil server)
(save-excursion
(nnmail-find-file nnfolder-active-file)
(setq nnfolder-group-alist (nnmail-get-active))))
(deffoo nnfolder-request-newgroups (date &optional server)
(nnfolder-possibly-change-group nil server)
(nnfolder-request-list server))
(deffoo nnfolder-request-list-newsgroups (&optional server)
(nnfolder-possibly-change-group nil server)
(save-excursion
(nnmail-find-file nnfolder-newsgroups-file)))
(deffoo nnfolder-request-expire-articles
(articles newsgroup &optional server force)
(nnfolder-possibly-change-group newsgroup server)
(let* ((is-old t)
rest)
(nnmail-activate 'nnfolder)
(save-excursion
(set-buffer nnfolder-current-buffer)
(while (and articles is-old)
(goto-char (point-min))
(if (search-forward (nnfolder-article-string (car articles)) nil t)
(if (setq is-old
(nnmail-expired-article-p
newsgroup
(buffer-substring
(point) (progn (end-of-line) (point)))
force nnfolder-inhibit-expiry))
(progn
(nnheader-message 5 "Deleting article %d..."
(car articles) newsgroup)
(nnfolder-delete-mail))
(setq rest (cons (car articles) rest))))
(setq articles (cdr articles)))
(nnfolder-save-buffer)
;; Find the lowest active article in this group.
(let* ((active (cadr (assoc newsgroup nnfolder-group-alist)))
(marker (concat "\n" nnfolder-article-marker))
(number "[0-9]+")
(activemin (cdr active)))
(goto-char (point-min))
(while (and (search-forward marker nil t)
(re-search-forward number nil t))
(setq activemin (min activemin
(string-to-number (buffer-substring
(match-beginning 0)
(match-end 0))))))
(setcar active activemin))
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nconc rest articles))))
(deffoo nnfolder-request-move-article
(article group server accept-form &optional last)
(nnfolder-possibly-change-group group server)
(let ((buf (get-buffer-create " *nnfolder move*"))
result)
(and
(nnfolder-request-article article group server)
(save-excursion
(set-buffer buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
(while (re-search-forward
(concat "^" nnfolder-article-marker)
(save-excursion (search-forward "\n\n" nil t) (point)) t)
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
(setq result (eval accept-form))
(kill-buffer buf)
result)
(save-excursion
(nnfolder-possibly-change-group group server)
(set-buffer nnfolder-current-buffer)
(goto-char (point-min))
(if (search-forward (nnfolder-article-string article) nil t)
(nnfolder-delete-mail))
(and last (nnfolder-save-buffer))))
result))
(deffoo nnfolder-request-accept-article (group &optional server last)
(nnfolder-possibly-change-group group server)
(nnmail-check-syntax)
(and (stringp group) (nnfolder-possibly-change-group group))
(let ((buf (current-buffer))
result)
(goto-char (point-min))
(when (looking-at "X-From-Line: ")
(replace-match "From "))
(and
(nnfolder-request-list)
(save-excursion
(set-buffer buf)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-line -1)
(while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
(delete-region (point) (progn (forward-line 1) (point))))
(setq result (car (nnfolder-save-mail (and (stringp group) group)))))
(save-excursion
(set-buffer nnfolder-current-buffer)
(and last (nnfolder-save-buffer))))
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(unless result
(nnheader-report 'nnfolder "Couldn't store article"))
result))
(deffoo nnfolder-request-replace-article (article group buffer)
(nnfolder-possibly-change-group group)
(save-excursion
(set-buffer nnfolder-current-buffer)
(goto-char (point-min))
(if (not (search-forward (nnfolder-article-string article) nil t))
nil
(nnfolder-delete-mail t t)
(insert-buffer-substring buffer)
(nnfolder-save-buffer)
t)))
(deffoo nnfolder-request-delete-group (group &optional force server)
(nnfolder-close-group group server t)
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
;; Delete the file that holds the group.
(condition-case nil
(delete-file (nnfolder-group-pathname group))
(error nil)))
;; Remove the group from all structures.
(setq nnfolder-group-alist
(delq (assoc group nnfolder-group-alist) nnfolder-group-alist)
nnfolder-current-group nil
nnfolder-current-buffer nil)
;; Save the active file.
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
t)
(deffoo nnfolder-request-rename-group (group new-name &optional server)
(nnfolder-possibly-change-group group server)
(save-excursion
(set-buffer nnfolder-current-buffer)
(and (file-writable-p buffer-file-name)
(condition-case ()
(progn
(rename-file
buffer-file-name
(nnfolder-group-pathname new-name))
t)
(error nil))
;; That went ok, so we change the internal structures.
(let ((entry (assoc group nnfolder-group-alist)))
(and entry (setcar entry new-name))
(setq nnfolder-current-buffer nil
nnfolder-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
;; We kill the buffer instead of renaming it and stuff.
(kill-buffer (current-buffer))
t))))
;;; Internal functions.
(defun nnfolder-article-string (article)
(if (numberp article)
(concat "\n" nnfolder-article-marker (int-to-string article) " ")
(concat "\nMessage-ID: " article)))
(defun nnfolder-delete-mail (&optional force leave-delim)
"Delete the message that point is in."
(save-excursion
(delete-region
(save-excursion
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
(if leave-delim (progn (forward-line 1) (point))
(match-beginning 0)))
(progn
(forward-line 1)
(if (re-search-forward (concat "^" message-unix-mail-delimiter) nil t)
(if (and (not (bobp)) leave-delim)
(progn (forward-line -2) (point))
(match-beginning 0))
(point-max))))))
;; When scanning, we're not looking t immediately switch into the group - if
;; we know our information is up to date, don't even bother reading the file.
(defun nnfolder-possibly-change-group (group &optional server scanning)
(when (and server
(not (nnfolder-server-opened server)))
(nnfolder-open-server server))
(when (and group (or nnfolder-current-buffer
(not (equal group nnfolder-current-group))))
(unless (file-exists-p nnfolder-directory)
(make-directory (directory-file-name nnfolder-directory) t))
(nnfolder-possibly-activate-groups nil)
(or (assoc group nnfolder-group-alist)
(not (file-exists-p
(nnfolder-group-pathname group)))
(progn
(setq nnfolder-group-alist
(cons (list group (cons 1 0)) nnfolder-group-alist))
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
(let (inf file)
(if (and (equal group nnfolder-current-group)
nnfolder-current-buffer
(buffer-name nnfolder-current-buffer))
()
(setq nnfolder-current-group group)
;; If we have to change groups, see if we don't already have the mbox
;; in memory. If we do, verify the modtime and destroy the mbox if
;; needed so we can rescan it.
(if (setq inf (assoc group nnfolder-buffer-alist))
(setq nnfolder-current-buffer (nth 1 inf)))
;; If the buffer is not live, make sure it isn't in the alist. If it
;; is live, verify that nobody else has touched the file since last
;; time.
(if (or (not (and nnfolder-current-buffer
(buffer-name nnfolder-current-buffer)))
(not (and (bufferp nnfolder-current-buffer)
(verify-visited-file-modtime
nnfolder-current-buffer))))
(progn
(if (and nnfolder-current-buffer
(buffer-name nnfolder-current-buffer)
(bufferp nnfolder-current-buffer))
(kill-buffer nnfolder-current-buffer))
(setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist))
(setq inf nil)))
(if inf
()
(save-excursion
(setq file (nnfolder-group-pathname group))
(if (file-directory-p (file-truename file))
()
(unless (file-exists-p file)
(unless (file-exists-p (file-name-directory file))
(make-directory (file-name-directory file) t))
(write-region 1 1 file t 'nomesg))
(setq nnfolder-current-buffer
(nnfolder-read-folder file scanning))
(if nnfolder-current-buffer
(progn
(set-buffer nnfolder-current-buffer)
(setq nnfolder-buffer-alist
(cons (list group nnfolder-current-buffer)
nnfolder-buffer-alist)))))))))
(setq nnfolder-current-group group)))
(defun nnfolder-save-mail (&optional group)
"Called narrowed to an article."
(let* ((nnmail-split-methods
(if group (list (list group "")) nnmail-split-methods))
(group-art-list
(nreverse (nnmail-article-group 'nnfolder-active-number)))
(delim (concat "^" message-unix-mail-delimiter))
save-list group-art)
(goto-char (point-min))
;; This might come from somewhere else.
(unless (looking-at delim)
(insert "From nobody " (current-time-string) "\n")
(goto-char (point-min)))
;; Quote all "From " lines in the article.
(forward-line 1)
(while (re-search-forward delim nil t)
(beginning-of-line)
(insert "> "))
(setq save-list group-art-list)
(nnmail-insert-lines)
(nnmail-insert-xref group-art-list)
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnfolder-prepare-save-mail-hook)
;; Insert the mail into each of the destination groups.
(while group-art-list
(setq group-art (car group-art-list)
group-art-list (cdr group-art-list))
;; Kill the previous newsgroup markers.
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-line -1)
(while (search-backward (concat "\n" nnfolder-article-marker) nil t)
(delete-region (1+ (point)) (progn (forward-line 2) (point))))
(nnfolder-possibly-change-group (car group-art))
;; Insert the new newsgroup marker.
(nnfolder-insert-newsgroup-line group-art)
(unless nnfolder-current-buffer
(nnfolder-close-group (car group-art))
(nnfolder-request-create-group (car group-art))
(nnfolder-possibly-change-group (car group-art)))
(let ((beg (point-min))
(end (point-max))
(obuf (current-buffer)))
(set-buffer nnfolder-current-buffer)
(goto-char (point-max))
(unless (eolp)
(insert "\n"))
(insert "\n")
(insert-buffer-substring obuf beg end)
(set-buffer obuf)))
;; Did we save it anywhere?
save-list))
(defun nnfolder-insert-newsgroup-line (group-art)
(save-excursion
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(progn
(forward-char -1)
(insert (format (concat nnfolder-article-marker "%d %s\n")
(cdr group-art) (current-time-string)))))))
(defun nnfolder-possibly-activate-groups (&optional group)
(save-excursion
;; If we're looking for the activation of a specific group, find out
;; its real name and switch to it.
(if group (nnfolder-possibly-change-group group))
;; If the group alist isn't active, activate it now.
(nnmail-activate 'nnfolder)))
(defun nnfolder-active-number (group)
(when group
(save-excursion
;; Find the next article number in GROUP.
(prog1
(let ((active (cadr (assoc group nnfolder-group-alist))))
(if active
(setcdr active (1+ (cdr active)))
;; This group is new, so we create a new entry for it.
;; This might be a bit naughty... creating groups on the drop of
;; a hat, but I don't know...
(setq nnfolder-group-alist
(cons (list group (setq active (cons 1 1)))
nnfolder-group-alist)))
(cdr active))
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
(nnfolder-possibly-activate-groups group)))))
;; This method has a problem if you've accidentally let the active list get
;; out of sync with the files. This could happen, say, if you've
;; accidentally gotten new mail with something other than Gnus (but why
;; would _that_ ever happen? :-). In that case, we will be in the middle of
;; processing the file, ready to add new X-Gnus article number markers, and
;; we'll run across a message with no ID yet - the active list _may_not_ be
;; ready for us yet.
;; To handle this, I'm modifying this routine to maintain the maximum ID seen
;; so far, and when we hit a message with no ID, we will _manually_ scan the
;; rest of the message looking for any more, possibly higher IDs. We'll
;; assume the maximum that we find is the highest active. Note that this
;; shouldn't cost us much extra time at all, but will be a lot less
;; vulnerable to glitches between the mbox and the active file.
(defun nnfolder-read-folder (file &optional scanning)
;; This is an attempt at a serious shortcut - don't even read in the file
;; if we know we've seen it since the last time it was touched.
(let ((scantime (cadr (assoc nnfolder-current-group
nnfolder-scantime-alist)))
(modtime (nth 5 (or (file-attributes file) '(nil nil nil nil nil)))))
(if (and scanning scantime
(eq (car scantime) (car modtime))
(eq (cdr scantime) (cadr modtime)))
nil
(save-excursion
(nnfolder-possibly-activate-groups nil)
;; Read in the file.
(set-buffer (setq nnfolder-current-buffer
(nnheader-find-file-noselect file nil 'raw)))
(buffer-disable-undo (current-buffer))
;; If the file hasn't been touched since the last time we scanned it,
;; don't bother doing anything with it.
(let ((delim (concat "^" message-unix-mail-delimiter))
(marker (concat "\n" nnfolder-article-marker))
(number "[0-9]+")
(active (or (cadr (assoc nnfolder-current-group
nnfolder-group-alist))
(cons 1 0)))
(scantime (assoc nnfolder-current-group nnfolder-scantime-alist))
(minid (lsh -1 -1))
maxid start end newscantime)
(setq maxid (or (cdr active) 0))
(goto-char (point-min))
;; Anytime the active number is 1 or 0, it is suspect. In that
;; case, search the file manually to find the active number. Or,
;; of course, if we're being paranoid. (This would also be the
;; place to build other lists from the header markers, such as
;; expunge lists, etc., if we ever desired to abandon the active
;; file entirely for mboxes.)
(when (or nnfolder-ignore-active-file
(< maxid 2))
(while (and (search-forward marker nil t)
(re-search-forward number nil t))
(let ((newnum (string-to-number (match-string 0))))
(setq maxid (max maxid newnum))
(setq minid (min minid newnum))))
(setcar active (max 1 (min minid maxid)))
(setcdr active (max maxid (cdr active)))
(goto-char (point-min)))
;; As long as we trust that the user will only insert unmarked mail
;; at the end, go to the end and search backwards for the last
;; marker. Find the start of that message, and begin to search for
;; unmarked messages from there.
(if (not (or nnfolder-distrust-mbox
(< maxid 2)))
(progn
(goto-char (point-max))
(if (not (re-search-backward marker nil t))
(goto-char (point-min))
(if (not (re-search-backward delim nil t))
(goto-char (point-min))))))
;; Keep track of the active number on our own, and insert it back
;; into the active list when we're done. Also, prime the pump to
;; cut down on the number of searches we do.
(setq end (point-marker))
(set-marker end (or (and (re-search-forward delim nil t)
(match-beginning 0))
(point-max)))
(while (not (= end (point-max)))
(setq start (marker-position end))
(goto-char end)
;; There may be more than one "From " line, so we skip past
;; them.
(while (looking-at delim)
(forward-line 1))
(set-marker end (or (and (re-search-forward delim nil t)
(match-beginning 0))
(point-max)))
(goto-char start)
(if (not (search-forward marker end t))
(progn
(narrow-to-region start end)
(nnmail-insert-lines)
(nnfolder-insert-newsgroup-line
(cons nil (nnfolder-active-number nnfolder-current-group)))
(widen))))
;; Make absolutely sure that the active list reflects reality!
(nnmail-save-active nnfolder-group-alist nnfolder-active-file)
;; Set the scantime for this group.
(setq newscantime (visited-file-modtime))
(if scantime
(setcdr scantime (list newscantime))
(push (list nnfolder-current-group newscantime)
nnfolder-scantime-alist))
(current-buffer))))))
;;;###autoload
(defun nnfolder-generate-active-file ()
"Look for mbox folders in the nnfolder directory and make them into groups."
(interactive)
(nnmail-activate 'nnfolder)
(let ((files (directory-files nnfolder-directory))
file)
(while (setq file (pop files))
(when (and (not (backup-file-name-p file))
(nnheader-mail-file-mbox-p file))
(nnheader-message 5 "Adding group %s..." file)
(push (list file (cons 1 0)) nnfolder-group-alist)
(nnfolder-possibly-change-group file)
;; (nnfolder-read-folder file)
(nnfolder-close-group file))
(message ""))))
(defun nnfolder-group-pathname (group)
"Make pathname for GROUP."
(let ((dir (file-name-as-directory (expand-file-name nnfolder-directory))))
;; If this file exists, we use it directly.
(if (or nnmail-use-long-file-names
(file-exists-p (concat dir group)))
(concat dir group)
;; If not, we translate dots into slashes.
(concat dir (nnheader-replace-chars-in-string group ?. ?/)))))
(defun nnfolder-save-buffer ()
"Save the buffer."
(when (buffer-modified-p)
(run-hooks 'nnfolder-save-buffer-hook)
(save-buffer)))
(provide 'nnfolder)
;;; nnfolder.el ends here

620
lisp/nnheader.el
View file

@ -1,620 +0,0 @@
;;; nnheader.el --- header access macros for Gnus and its backends
;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; 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:
(require 'mail-utils)
(eval-when-compile (require 'cl))
(defvar nnheader-max-head-length 4096
"*Max length of the head of articles.")
(defvar nnheader-file-name-translation-alist nil
"*Alist that says how to translate characters in file names.
For instance, if \":\" is illegal as a file character in file names
on your system, you could say something like:
\(setq nnheader-file-name-translation-alist '((?: . ?_)))")
;;; Header access macros.
(defmacro mail-header-number (header)
"Return article number in HEADER."
`(aref ,header 0))
(defmacro mail-header-set-number (header number)
"Set article number of HEADER to NUMBER."
`(aset ,header 0 ,number))
(defmacro mail-header-subject (header)
"Return subject string in HEADER."
`(aref ,header 1))
(defmacro mail-header-set-subject (header subject)
"Set article subject of HEADER to SUBJECT."
`(aset ,header 1 ,subject))
(defmacro mail-header-from (header)
"Return author string in HEADER."
`(aref ,header 2))
(defmacro mail-header-set-from (header from)
"Set article author of HEADER to FROM."
`(aset ,header 2 ,from))
(defmacro mail-header-date (header)
"Return date in HEADER."
`(aref ,header 3))
(defmacro mail-header-set-date (header date)
"Set article date of HEADER to DATE."
`(aset ,header 3 ,date))
(defalias 'mail-header-message-id 'mail-header-id)
(defmacro mail-header-id (header)
"Return Id in HEADER."
`(aref ,header 4))
(defalias 'mail-header-set-message-id 'mail-header-set-id)
(defmacro mail-header-set-id (header id)
"Set article Id of HEADER to ID."
`(aset ,header 4 ,id))
(defmacro mail-header-references (header)
"Return references in HEADER."
`(aref ,header 5))
(defmacro mail-header-set-references (header ref)
"Set article references of HEADER to REF."
`(aset ,header 5 ,ref))
(defmacro mail-header-chars (header)
"Return number of chars of article in HEADER."
`(aref ,header 6))
(defmacro mail-header-set-chars (header chars)
"Set number of chars in article of HEADER to CHARS."
`(aset ,header 6 ,chars))
(defmacro mail-header-lines (header)
"Return lines in HEADER."
`(aref ,header 7))
(defmacro mail-header-set-lines (header lines)
"Set article lines of HEADER to LINES."
`(aset ,header 7 ,lines))
(defmacro mail-header-xref (header)
"Return xref string in HEADER."
`(aref ,header 8))
(defmacro mail-header-set-xref (header xref)
"Set article xref of HEADER to xref."
`(aset ,header 8 ,xref))
(defun make-mail-header (&optional init)
"Create a new mail header structure initialized with INIT."
(make-vector 9 init))
;; Parsing headers and NOV lines.
(defsubst nnheader-header-value ()
(buffer-substring (match-end 0) (gnus-point-at-eol)))
(defvar nnheader-newsgroup-none-id 1)
(defun nnheader-parse-head (&optional naked)
(let ((case-fold-search t)
(cur (current-buffer))
(buffer-read-only nil)
end ref in-reply-to lines p)
(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.
(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
;; doesn't always go hand in hand.
(vector
;; 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)
(nnheader-header-value)
;; If there was no message-id, we just fake one to make
;; subsequent routines simpler.
(concat "none+"
(int-to-string
(incf nnheader-newsgroup-none-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 "<[^>]+>" in-reply-to))
(substring in-reply-to (match-beginning 0)
(match-end 0))
"")))
;; 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)))))
(when naked
(goto-char (point-min))
(delete-char 1)))))
(defun nnheader-insert-nov (header)
(princ (mail-header-number header) (current-buffer))
(insert
"\t"
(or (mail-header-subject header) "(none)") "\t"
(or (mail-header-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")
(princ (or (mail-header-lines header) 0) (current-buffer))
(insert "\t")
(when (mail-header-xref header)
(insert "Xref: " (mail-header-xref header) "\t"))
(insert "\n"))
(defun nnheader-insert-article-line (article)
(goto-char (point-min))
(insert "220 ")
(princ article (current-buffer))
(insert " Article retrieved.\n")
(search-forward "\n\n" nil 'move)
(delete-region (point) (point-max))
(forward-char -1)
(insert "."))
;; Various cruft the backends and Gnus need to communicate.
(defvar nntp-server-buffer nil)
(defvar gnus-verbose-backends 7
"*A number that says how talkative the Gnus backends should be.")
(defvar gnus-nov-is-evil nil
"If non-nil, Gnus backends will never output headers in the NOV format.")
(defvar news-reply-yank-from nil)
(defvar news-reply-yank-message-id nil)
(defvar nnheader-callback-function nil)
(defun nnheader-init-server-buffer ()
"Initialize the Gnus-backend communication buffer."
(save-excursion
(setq nntp-server-buffer (get-buffer-create " *nntpd*"))
(set-buffer nntp-server-buffer)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(kill-all-local-variables)
(setq case-fold-search t) ;Should ignore case.
t))
;;; Various functions the backends use.
(defun nnheader-file-error (file)
"Return a string that says what is wrong with FILE."
(format
(cond
((not (file-exists-p file))
"%s does not exist")
((file-directory-p file)
"%s is a directory")
((not (file-readable-p file))
"%s is not readable"))
file))
(defun nnheader-insert-head (file)
"Insert the head of the article."
(when (file-exists-p file)
(if (eq nnheader-max-head-length t)
;; Just read the entire file.
(nnheader-insert-file-contents-literally file)
;; Read 1K blocks until we find a separator.
(let ((beg 0)
format-alist
(chop 1024))
(while (and (not (zerop (nth 1 (insert-file-contents
file nil beg (incf beg chop)))))
(prog1 (not (search-forward "\n\n" nil t))
(goto-char (point-max)))
(or (null nnheader-max-head-length)
(< beg nnheader-max-head-length))))))
t))
(defun nnheader-article-p ()
"Say whether the current buffer looks like an article."
(goto-char (point-min))
(if (not (search-forward "\n\n" nil t))
nil
(narrow-to-region (point-min) (1- (point)))
(goto-char (point-min))
(while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
(goto-char (match-end 0)))
(prog1
(eobp)
(widen))))
(defun nnheader-insert-references (references message-id)
"Insert a References header based on REFERENCES and MESSAGE-ID."
(if (and (not references) (not message-id))
() ; This is illegal, but not all articles have Message-IDs.
(mail-position-on-field "References")
(let ((begin (save-excursion (beginning-of-line) (point)))
(fill-column 78)
(fill-prefix "\t"))
(if references (insert references))
(if (and references message-id) (insert " "))
(if message-id (insert message-id))
;; Fold long References lines to conform to RFC1036 (sort of).
;; The region must end with a newline to fill the region
;; without inserting extra newline.
(fill-region-as-paragraph begin (1+ (point))))))
(defun nnheader-replace-header (header new-value)
"Remove HEADER and insert the NEW-VALUE."
(save-excursion
(save-restriction
(nnheader-narrow-to-headers)
(prog1
(message-remove-header header)
(goto-char (point-max))
(insert header ": " new-value "\n")))))
(defun nnheader-narrow-to-headers ()
"Narrow to the head of an article."
(widen)
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(1- (point))
(point-max)))
(goto-char (point-min)))
(defun nnheader-set-temp-buffer (name)
"Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
(set-buffer (get-buffer-create name))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(current-buffer))
(defmacro nnheader-temp-write (file &rest forms)
"Create a new buffer, evaluate FORM there, and write the buffer to FILE."
`(save-excursion
(let ((nnheader-temp-file ,file)
(nnheader-temp-cur-buffer
(nnheader-set-temp-buffer
(generate-new-buffer-name " *nnheader temp*"))))
(when (and nnheader-temp-file
(not (file-directory-p (file-name-directory
nnheader-temp-file))))
(make-directory (file-name-directory nnheader-temp-file) t))
(unwind-protect
(prog1
(progn
,@forms)
(when nnheader-temp-file
(set-buffer nnheader-temp-cur-buffer)
(write-region (point-min) (point-max)
nnheader-temp-file nil 'nomesg)))
(when (buffer-name nnheader-temp-cur-buffer)
(kill-buffer nnheader-temp-cur-buffer))))))
(put 'nnheader-temp-write 'lisp-indent-function 1)
(put 'nnheader-temp-write 'lisp-indent-hook 1)
(put 'nnheader-temp-write 'edebug-form-spec '(form body))
(defvar jka-compr-compression-info-list)
(defvar nnheader-numerical-files
(if (boundp 'jka-compr-compression-info-list)
(concat "\\([0-9]+\\)\\("
(mapconcat (lambda (i) (aref i 0))
jka-compr-compression-info-list "\\|")
"\\)?")
"[0-9]+$")
"Regexp that match numerical files.")
(defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
"Regexp that matches numerical file names.")
(defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
"Regexp that matches numerical full file paths.")
(defsubst nnheader-file-to-number (file)
"Take a file name and return the article number."
(if (not (boundp 'jka-compr-compression-info-list))
(string-to-int file)
(string-match nnheader-numerical-short-files file)
(string-to-int (match-string 0 file))))
(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.
(let ((first (apply 'directory-files args))
(second (apply 'directory-files args)))
(if (> (length first) (length second))
first
second)))
(defun nnheader-directory-articles (dir)
"Return a list of all article files in a directory."
(mapcar 'nnheader-file-to-number
(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)))
(defun nnheader-fold-continuation-lines ()
"Fold continuation lines in the current buffer."
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t)))
(defun nnheader-translate-file-chars (file)
(if (null nnheader-file-name-translation-alist)
;; No translation is necessary.
file
;; We translate -- but only the file name. We leave the directory
;; alone.
(let* ((i 0)
trans leaf path len)
(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.
(setq leaf (file-name-nondirectory file)
path (file-name-directory file)))
(setq len (length leaf))
(while (< i len)
(when (setq trans (cdr (assq (aref leaf i)
nnheader-file-name-translation-alist)))
(aset leaf i trans))
(incf i))
(concat path leaf))))
(defun nnheader-report (backend &rest args)
"Report an error from the BACKEND.
The first string in ARGS can be a format string."
(set (intern (format "%s-status-string" backend))
(if (< (length args) 2)
(car args)
(apply 'format args)))
nil)
(defun nnheader-get-report (backend)
(message "%s" (symbol-value (intern (format "%s-status-string" backend)))))
(defun nnheader-insert (format &rest args)
"Clear the communicaton buffer and insert FORMAT and ARGS into the buffer.
If FORMAT isn't a format string, it and all ARGS will be inserted
without formatting."
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if (string-match "%" format)
(insert (apply 'format format args))
(apply 'insert format args))
t))
(defun nnheader-mail-file-mbox-p (file)
"Say whether FILE looks like an Unix mbox file."
(when (and (file-exists-p file)
(file-readable-p file)
(file-regular-p file))
(save-excursion
(nnheader-set-temp-buffer " *mail-file-mbox-p*")
(nnheader-insert-file-contents-literally file)
(goto-char (point-min))
(prog1
(looking-at message-unix-mail-delimiter)
(kill-buffer (current-buffer))))))
(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)
(if (= (aref string idx) from)
(aset string idx to))
(setq idx (1+ idx)))
string))
(defun nnheader-file-to-group (file &optional top)
"Return a group name based on FILE and TOP."
(nnheader-replace-chars-in-string
(if (not top)
file
(condition-case ()
(substring (expand-file-name file)
(length
(expand-file-name
(file-name-as-directory top))))
(error "")))
?/ ?.))
(defun nnheader-message (level &rest args)
"Message if the Gnus backends are talkative."
(if (or (not (numberp gnus-verbose-backends))
(<= level gnus-verbose-backends))
(apply 'message args)
(apply 'format args)))
(defun nnheader-be-verbose (level)
"Return whether the backends should be verbose on LEVEL."
(or (not (numberp gnus-verbose-backends))
(<= level gnus-verbose-backends)))
(defun nnheader-group-pathname (group dir &optional file)
"Make pathname for GROUP."
(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 (nnheader-replace-chars-in-string group ?. ?/) "/")))
(cond ((null file) "")
((numberp file) (int-to-string file))
(t file))))
(defun nnheader-functionp (form)
"Return non-nil if FORM is funcallable."
(or (and (symbolp form) (fboundp form))
(and (listp form) (eq (car form) 'lambda))))
(defun nnheader-concat (dir file)
"Concat DIR as directory to FILE."
(concat (file-name-as-directory dir) file))
(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))))
(defun nnheader-file-size (file)
"Return the file size of FILE or 0."
(or (nth 7 (file-attributes file)) 0))
(defun nnheader-find-etc-directory (package)
"Go through the path and find the \".../etc/PACKAGE\" directory."
(let ((path load-path)
dir result)
;; We try to find the dir by looking at the load path,
;; stripping away the last component and adding "etc/".
(while path
(if (and (car path)
(file-exists-p
(setq dir (concat
(file-name-directory
(directory-file-name (car path)))
"etc/" package "/")))
(file-directory-p dir))
(setq result dir
path nil)
(setq path (cdr path))))
result))
(defvar ange-ftp-path-format)
(defvar efs-path-regexp)
(defun nnheader-re-read-dir (path)
"Re-read directory PATH if PATH is on a remote system."
(if (boundp 'ange-ftp-path-format)
(when (string-match (car ange-ftp-path-format) path)
(ange-ftp-re-read-dir path))
(if (boundp 'efs-path-regexp)
(when (string-match efs-path-regexp path)
(efs-re-read-dir path)))))
(fset 'nnheader-run-at-time 'run-at-time)
(fset 'nnheader-cancel-timer 'cancel-timer)
(fset 'nnheader-find-file-noselect 'find-file-noselect)
(fset 'nnheader-insert-file-contents-literally
'insert-file-contents-literally)
(when (string-match "XEmacs\\|Lucid" emacs-version)
(require 'nnheaderxm))
(run-hooks 'nnheader-load-hook)
(provide 'nnheader)
;;; nnheader.el ends here

201
lisp/nnheaderems.el
View file

@ -1,201 +0,0 @@
;;; nnheaderems.el --- making Gnus backends work under different Emacsen
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(defun nnheader-xmas-run-at-time (time repeat function &rest args)
(start-itimer
"nnheader-run-at-time"
`(lambda ()
(,function ,@args))
time repeat))
(defun nnheader-xmas-cancel-timer (timer)
(delete-itimer timer))
;; Written by Erik Naggum <erik@naggum.no>.
;; Saved by Steve Baur <steve@miranova.com>.
(defun nnheader-xmas-insert-file-contents-literally (filename &optional visit beg end replace)
"Like `insert-file-contents', q.v., but only reads in the file.
A buffer may be modified in several ways after reading into the buffer due
to advanced Emacs features, such as file-name-handlers, format decoding,
find-file-hooks, etc.
This function ensures that none of these modifications will take place."
(let ( ; (file-name-handler-alist nil)
(format-alist nil)
(after-insert-file-functions nil)
(find-buffer-file-type-function
(if (fboundp 'find-buffer-file-type)
(symbol-function 'find-buffer-file-type)
nil)))
(unwind-protect
(progn
(fset 'find-buffer-file-type (lambda (filename) t))
(insert-file-contents filename visit beg end replace))
(if find-buffer-file-type-function
(fset 'find-buffer-file-type find-buffer-file-type-function)
(fmakunbound 'find-buffer-file-type)))))
(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile)
"Read file FILENAME into a buffer and return the buffer.
If a buffer exists visiting FILENAME, return that one, but
verify that the file has not changed since visited or saved.
The buffer is not selected, just returned to the caller."
(setq filename
(abbreviate-file-name
(expand-file-name filename)))
(if (file-directory-p filename)
(if find-file-run-dired
(dired-noselect filename)
(error "%s is a directory." filename))
(let* ((buf (get-file-buffer filename))
(truename (abbreviate-file-name (file-truename filename)))
(number (nthcdr 10 (file-attributes truename)))
;; Find any buffer for a file which has same truename.
(other (and (not buf)
(if (fboundp 'find-buffer-visiting)
(find-buffer-visiting filename)
(get-file-buffer filename))))
error)
;; Let user know if there is a buffer with the same truename.
(if other
(progn
(or nowarn
(string-equal filename (buffer-file-name other))
(message "%s and %s are the same file"
filename (buffer-file-name other)))
;; Optionally also find that buffer.
(if (or (and (boundp 'find-file-existing-other-name)
find-file-existing-other-name)
find-file-visit-truename)
(setq buf other))))
(if buf
(or nowarn
(verify-visited-file-modtime buf)
(cond ((not (file-exists-p filename))
(error "File %s no longer exists!" filename))
((yes-or-no-p
(if (string= (file-name-nondirectory filename)
(buffer-name buf))
(format
(if (buffer-modified-p buf)
"File %s changed on disk. Discard your edits? "
"File %s changed on disk. Reread from disk? ")
(file-name-nondirectory filename))
(format
(if (buffer-modified-p buf)
"File %s changed on disk. Discard your edits in %s? "
"File %s changed on disk. Reread from disk into %s? ")
(file-name-nondirectory filename)
(buffer-name buf))))
(save-excursion
(set-buffer buf)
(revert-buffer t t)))))
(save-excursion
;;; The truename stuff makes this obsolete.
;;; (let* ((link-name (car (file-attributes filename)))
;;; (linked-buf (and (stringp link-name)
;;; (get-file-buffer link-name))))
;;; (if (bufferp linked-buf)
;;; (message "Symbolic link to file in buffer %s"
;;; (buffer-name linked-buf))))
(setq buf (create-file-buffer filename))
;; (set-buffer-major-mode buf)
(set-buffer buf)
(erase-buffer)
(if rawfile
(condition-case ()
(nnheader-insert-file-contents-literally filename t)
(file-error
;; Unconditionally set error
(setq error t)))
(condition-case ()
(insert-file-contents filename t)
(file-error
;; Run find-file-not-found-hooks until one returns non-nil.
(or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks)
;; If they fail too, set error.
(setq error t)))))
;; Find the file's truename, and maybe use that as visited name.
(setq buffer-file-truename truename)
(setq buffer-file-number number)
;; On VMS, we may want to remember which directory in a search list
;; the file was found in.
(and (eq system-type 'vax-vms)
(let (logical)
(if (string-match ":" (file-name-directory filename))
(setq logical (substring (file-name-directory filename)
0 (match-beginning 0))))
(not (member logical find-file-not-true-dirname-list)))
(setq buffer-file-name buffer-file-truename))
(if find-file-visit-truename
(setq buffer-file-name
(setq filename
(expand-file-name buffer-file-truename))))
;; Set buffer's default directory to that of the file.
(setq default-directory (file-name-directory filename))
;; Turn off backup files for certain file names. Since
;; this is a permanent local, the major mode won't eliminate it.
(and (not (funcall backup-enable-predicate buffer-file-name))
(progn
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
(if rawfile
nil
(after-find-file error (not nowarn)))))
buf)))
(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))))
(eval-and-compile
(cond
;; Do XEmacs function bindings.
((string-match "XEmacs\\|Lucid" emacs-version)
(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time)
(fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer)
(fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect)
(fset 'nnheader-insert-file-contents-literally
(if (fboundp 'insert-file-contents-literally)
'insert-file-contents-literally
'nnheader-xmas-insert-file-contents-literally)))
;; Do Emacs function bindings.
(t
(fset 'nnheader-run-at-time 'run-at-time)
(fset 'nnheader-cancel-timer 'cancel-timer)
(fset 'nnheader-find-file-noselect 'find-file-noselect)
(fset 'nnheader-insert-file-contents-literally
'insert-file-contents-literally)
))
(when (memq system-type '(windows-nt))
(add-hook 'nnmail-prepare-incoming-hook 'nnheader-ms-strip-cr)))
(provide 'nnheaderems)
;;; nnheaderems.el ends here.

388
lisp/nnkiboze.el
View file

@ -1,388 +0,0 @@
;;; nnkiboze.el --- select virtual news access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; The other access methods (nntp, nnspool, etc) are general news
;; access methods. This module relies on Gnus and can not be used
;; separately.
;;; Code:
(require 'nntp)
(require 'nnheader)
(require 'gnus)
(require 'gnus-score)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnkiboze)
(defvoo nnkiboze-directory gnus-directory
"nnkiboze will put its files in this directory.")
(defvoo nnkiboze-level 9
"*The maximum level to be searched for articles.")
(defvoo nnkiboze-remove-read-articles t
"*If non-nil, nnkiboze will remove read articles from the kiboze group.")
(defconst nnkiboze-version "nnkiboze 1.0"
"Version numbers of this version of nnkiboze.")
(defvoo nnkiboze-current-group nil)
(defvoo nnkiboze-current-score-group "")
(defvoo nnkiboze-status-string "")
;;; Interface functions.
(nnoo-define-basics nnkiboze)
(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old)
(nnkiboze-possibly-change-newsgroups group)
(if gnus-nov-is-evil
nil
(if (stringp (car articles))
'headers
(let ((first (car articles))
(last (progn (while (cdr articles) (setq articles (cdr articles)))
(car articles)))
(nov (nnkiboze-nov-file-name)))
(if (file-exists-p nov)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-file-contents nov)
(goto-char (point-min))
(while (and (not (eobp)) (< first (read (current-buffer))))
(forward-line 1))
(beginning-of-line)
(if (not (eobp)) (delete-region 1 (point)))
(while (and (not (eobp)) (>= last (read (current-buffer))))
(forward-line 1))
(beginning-of-line)
(if (not (eobp)) (delete-region (point) (point-max)))
'nov))))))
(deffoo nnkiboze-open-server (newsgroups &optional something)
(gnus-make-directory nnkiboze-directory)
(nnheader-init-server-buffer))
(deffoo nnkiboze-server-opened (&optional server)
(and nntp-server-buffer
(get-buffer nntp-server-buffer)))
(deffoo nnkiboze-request-article (article &optional newsgroup server buffer)
(nnkiboze-possibly-change-newsgroups newsgroup)
(if (not (numberp article))
;; This is a real kludge. It might not work at times, but it
;; does no harm I think. The only alternative is to offer no
;; article fetching by message-id at all.
(nntp-request-article article newsgroup gnus-nntp-server buffer)
(let* ((header (gnus-summary-article-header article))
(xref (mail-header-xref header))
igroup iarticle)
(or xref (error "nnkiboze: No xref"))
(or (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
(error "nnkiboze: Malformed xref"))
(setq igroup (substring xref (match-beginning 1) (match-end 1)))
(setq iarticle (string-to-int
(substring xref (match-beginning 2) (match-end 2))))
(and (gnus-request-group igroup t)
(gnus-request-article iarticle igroup buffer)))))
(deffoo nnkiboze-request-group (group &optional server dont-check)
"Make GROUP the current newsgroup."
(nnkiboze-possibly-change-newsgroups group)
(if dont-check
()
(let ((nov-file (nnkiboze-nov-file-name))
beg end total)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if (not (file-exists-p nov-file))
(insert (format "211 0 0 0 %s\n" group))
(insert-file-contents nov-file)
(if (zerop (buffer-size))
(insert (format "211 0 0 0 %s\n" group))
(goto-char (point-min))
(and (looking-at "[0-9]+") (setq beg (read (current-buffer))))
(goto-char (point-max))
(and (re-search-backward "^[0-9]" nil t)
(setq end (read (current-buffer))))
(setq total (count-lines (point-min) (point-max)))
(erase-buffer)
(insert (format "211 %d %d %d %s\n" total beg end group)))))))
t)
(deffoo nnkiboze-close-group (group &optional server)
(nnkiboze-possibly-change-newsgroups group)
;; Remove NOV lines of articles that are marked as read.
(when (and (file-exists-p (nnkiboze-nov-file-name))
nnkiboze-remove-read-articles
(eq major-mode 'gnus-summary-mode))
(save-excursion
(let ((unreads gnus-newsgroup-unreads)
(unselected gnus-newsgroup-unselected)
(version-control 'never))
(set-buffer (get-buffer-create "*nnkiboze work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(let ((cur (current-buffer))
article)
(insert-file-contents (nnkiboze-nov-file-name))
(goto-char (point-min))
(while (looking-at "[0-9]+")
(if (or (memq (setq article (read cur)) unreads)
(memq article unselected))
(forward-line 1)
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point)))))
(write-file (nnkiboze-nov-file-name))
(kill-buffer (current-buffer)))))
(setq nnkiboze-current-group nil)))
(deffoo nnkiboze-request-list (&optional server)
(nnheader-report 'nnkiboze "LIST is not implemented."))
(deffoo nnkiboze-request-newgroups (date &optional server)
"List new groups."
(nnheader-report 'nnkiboze "NEWGROUPS is not supported."))
(deffoo nnkiboze-request-list-newsgroups (&optional server)
(nnheader-report 'nnkiboze "LIST NEWSGROUPS is not implemented."))
(deffoo nnkiboze-request-delete-group (group &optional force server)
(nnkiboze-possibly-change-newsgroups group)
(when force
(let ((files (list (nnkiboze-nov-file-name)
(concat nnkiboze-directory group ".newsrc")
(nnkiboze-score-file group))))
(while files
(and (file-exists-p (car files))
(file-writable-p (car files))
(delete-file (car files)))
(setq files (cdr files)))))
(setq nnkiboze-current-group nil))
;;; Internal functions.
(defun nnkiboze-possibly-change-newsgroups (group)
(setq nnkiboze-current-group group))
(defun nnkiboze-prefixed-name (group)
(gnus-group-prefixed-name group '(nnkiboze "")))
;;;###autoload
(defun nnkiboze-generate-groups ()
"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups
Finds out what articles are to be part of the nnkiboze groups."
(interactive)
(let ((nnmail-spool-file nil)
(gnus-use-dribble-file nil)
(gnus-read-active-file t)
(gnus-expert-user t))
(gnus))
(let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
(newsrc gnus-newsrc-alist)
gnus-newsrc-hashtb)
(gnus-make-hashtable-from-newsrc-alist)
;; We have copied all the newsrc alist info over to local copies
;; so that we can mess all we want with these lists.
(while newsrc
(if (string-match "nnkiboze" (caar newsrc))
;; For each kiboze group, we call this function to generate
;; it.
(nnkiboze-generate-group (caar newsrc)))
(setq newsrc (cdr newsrc)))))
(defun nnkiboze-score-file (group)
(list (expand-file-name
(concat (file-name-as-directory gnus-kill-files-directory)
(nnheader-translate-file-chars
(concat nnkiboze-current-score-group
"." gnus-score-file-suffix))))))
(defun nnkiboze-generate-group (group)
(let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
(newsrc-file (concat nnkiboze-directory group ".newsrc"))
(nov-file (concat nnkiboze-directory group ".nov"))
(regexp (nth 1 (nth 4 info)))
(gnus-expert-user t)
(gnus-large-newsgroup nil)
(version-control 'never)
(gnus-score-find-score-files-function 'nnkiboze-score-file)
gnus-select-group-hook gnus-summary-prepare-hook
gnus-thread-sort-functions gnus-show-threads
gnus-visual
method nnkiboze-newsrc nov-buffer gname newsrc active
ginfo lowest glevel)
(setq nnkiboze-current-score-group group)
(or info (error "No such group: %s" group))
;; Load the kiboze newsrc file for this group.
(and (file-exists-p newsrc-file) (load newsrc-file))
;; We also load the nov file for this group.
(save-excursion
(set-buffer (setq nov-buffer (find-file-noselect nov-file)))
(buffer-disable-undo (current-buffer)))
;; Go through the active hashtb and add new all groups that match the
;; kiboze regexp.
(mapatoms
(lambda (group)
(and (string-match regexp (setq gname (symbol-name group))) ; Match
(not (assoc gname nnkiboze-newsrc)) ; It isn't registered
(numberp (car (symbol-value group))) ; It is active
(or (> nnkiboze-level 7)
(and (setq glevel (nth 1 (nth 2 (gnus-gethash
gname gnus-newsrc-hashtb))))
(>= nnkiboze-level glevel)))
(not (string-match "^nnkiboze:" gname)) ; Exclude kibozes
(setq nnkiboze-newsrc
(cons (cons gname (1- (car (symbol-value group))))
nnkiboze-newsrc))))
gnus-active-hashtb)
;; `newsrc' is set to the list of groups that possibly are
;; component groups to this kiboze group. This list has elements
;; on the form `(GROUP . NUMBER)', where NUMBER is the highest
;; number that has been kibozed in GROUP in this kiboze group.
(setq newsrc nnkiboze-newsrc)
(while newsrc
(if (not (setq active (gnus-gethash
(caar newsrc) gnus-active-hashtb)))
;; This group isn't active after all, so we remove it from
;; the list of component groups.
(setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
(setq lowest (cdar newsrc))
;; Ok, we have a valid component group, so we jump to it.
(switch-to-buffer gnus-group-buffer)
(gnus-group-jump-to-group (caar newsrc))
;; We set all list of article marks to nil. Since we operate
;; on copies of the real lists, we can destroy anything we
;; want here.
(and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name)
gnus-newsrc-hashtb)))
(nth 3 ginfo)
(setcar (nthcdr 3 ginfo) nil))
;; We set the list of read articles to be what we expect for
;; this kiboze group -- either nil or `(1 . LOWEST)'.
(and ginfo (setcar (nthcdr 2 ginfo)
(and (not (= lowest 1)) (cons 1 lowest))))
(if (not (and (or (not ginfo)
(> (length (gnus-list-of-unread-articles
(car ginfo))) 0))
(progn
(gnus-group-select-group nil)
(eq major-mode 'gnus-summary-mode))))
() ; No unread articles, or we couldn't enter this group.
;; We are now in the group where we want to be.
(setq method (gnus-find-method-for-group gnus-newsgroup-name))
(and (eq method gnus-select-method) (setq method nil))
;; We go through the list of scored articles.
(while gnus-newsgroup-scored
(if (> (caar gnus-newsgroup-scored) lowest)
;; If it has a good score, then we enter this article
;; into the kiboze group.
(nnkiboze-enter-nov
nov-buffer
(gnus-summary-article-header
(caar gnus-newsgroup-scored))
(if method
(gnus-group-prefixed-name gnus-newsgroup-name method)
gnus-newsgroup-name)))
(setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
;; That's it. We exit this group.
(gnus-summary-exit-no-update)))
(setcdr (car newsrc) (car active))
(setq newsrc (cdr newsrc)))
;; We save the nov file.
(set-buffer nov-buffer)
(save-buffer)
(kill-buffer (current-buffer))
;; We save the kiboze newsrc for this group.
(set-buffer (get-buffer-create "*nnkiboze work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert "(setq nnkiboze-newsrc '" (prin1-to-string nnkiboze-newsrc)
")\n")
(write-file newsrc-file)
(kill-buffer (current-buffer))
(switch-to-buffer gnus-group-buffer)
(gnus-group-list-groups 5 nil)))
(defun nnkiboze-enter-nov (buffer header group)
(save-excursion
(set-buffer buffer)
(goto-char (point-max))
(let ((xref (mail-header-xref header))
(prefix (gnus-group-real-prefix group))
(first t)
article)
(if (zerop (forward-line -1))
(progn
(setq article (1+ (read (current-buffer))))
(forward-line 1))
(setq article 1))
(insert (int-to-string article) "\t"
(or (mail-header-subject header) "") "\t"
(or (mail-header-from header) "") "\t"
(or (mail-header-date header) "") "\t"
(or (mail-header-id header) "") "\t"
(or (mail-header-references header) "") "\t"
(int-to-string (or (mail-header-chars header) 0)) "\t"
(int-to-string (or (mail-header-lines header) 0)) "\t")
(if (or (not xref) (equal "" xref))
(insert "Xref: " (system-name) " " group ":"
(int-to-string (mail-header-number header))
"\t\n")
(insert (mail-header-xref header) "\t\n")
(search-backward "\t" nil t)
(search-backward "\t" nil t)
(while (re-search-forward
"[^ ]+:[0-9]+"
(save-excursion (end-of-line) (point)) t)
(if first
;; The first xref has to be the group this article
;; really came for - this is the article nnkiboze
;; will request when it is asked for the article.
(save-excursion
(goto-char (match-beginning 0))
(insert prefix group ":"
(int-to-string (mail-header-number header)) " ")
(setq first nil)))
(save-excursion
(goto-char (match-beginning 0))
(insert prefix)))))))
(defun nnkiboze-nov-file-name ()
(concat (file-name-as-directory nnkiboze-directory)
(nnheader-translate-file-chars
(concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))))
(provide 'nnkiboze)
;;; nnkiboze.el ends here

1201
lisp/nnmail.el
View file

File diff suppressed because it is too large Load diff

533
lisp/nnmbox.el
View file

@ -1,533 +0,0 @@
;;; nnmbox.el --- mail mbox access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; For an overview of what the interface functions do, please see the
;; Gnus sources.
;;; Code:
(require 'nnheader)
(require 'message)
(require 'nnmail)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnmbox)
(defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
"The name of the mail box file in the user's home directory.")
(defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
"The name of the active file for the mail box.")
(defvoo nnmbox-get-new-mail t
"If non-nil, nnmbox will check the incoming mail file and split the mail.")
(defvoo nnmbox-prepare-save-mail-hook nil
"Hook run narrowed to an article before saving.")
(defconst nnmbox-version "nnmbox 1.0"
"nnmbox version.")
(defvoo nnmbox-current-group nil
"Current nnmbox news group directory.")
(defconst nnmbox-mbox-buffer nil)
(defvoo nnmbox-status-string "")
(defvoo nnmbox-group-alist nil)
(defvoo nnmbox-active-timestamp nil)
;;; Interface functions
(nnoo-define-basics nnmbox)
(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((number (length sequence))
(count 0)
article art-string start stop)
(nnmbox-possibly-change-newsgroup newsgroup server)
(while sequence
(setq article (car sequence))
(setq art-string (nnmbox-article-string article))
(set-buffer nnmbox-mbox-buffer)
(if (or (search-forward art-string nil t)
(progn (goto-char (point-min))
(search-forward art-string nil t)))
(progn
(setq start
(save-excursion
(re-search-backward
(concat "^" message-unix-mail-delimiter) nil t)
(point)))
(search-forward "\n\n" nil t)
(setq stop (1- (point)))
(set-buffer nntp-server-buffer)
(insert (format "221 %d Article retrieved.\n" article))
(insert-buffer-substring nnmbox-mbox-buffer start stop)
(goto-char (point-max))
(insert ".\n")))
(setq sequence (cdr sequence))
(setq count (1+ count))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(zerop (% count 20))
(nnheader-message 5 "nnmbox: Receiving headers... %d%%"
(/ (* count 100) number))))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(nnheader-message 5 "nnmbox: Receiving headers...done"))
(set-buffer nntp-server-buffer)
(nnheader-fold-continuation-lines)
'headers)))
(deffoo nnmbox-open-server (server &optional defs)
(nnoo-change-server 'nnmbox server defs)
(cond
((not (file-exists-p nnmbox-mbox-file))
(nnmbox-close-server)
(nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
((file-directory-p nnmbox-mbox-file)
(nnmbox-close-server)
(nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
(t
(nnheader-report 'nnmbox "Opened server %s using mbox %s" server
nnmbox-mbox-file)
t)))
(deffoo nnmbox-close-server (&optional server)
(when (and nnmbox-mbox-buffer
(buffer-name nnmbox-mbox-buffer))
(kill-buffer nnmbox-mbox-buffer))
(nnoo-close-server 'nnmbox server)
t)
(deffoo nnmbox-server-opened (&optional server)
(and (nnoo-current-server-p 'nnmbox server)
nnmbox-mbox-buffer
(buffer-name nnmbox-mbox-buffer)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(deffoo nnmbox-request-article (article &optional newsgroup server buffer)
(nnmbox-possibly-change-newsgroup newsgroup server)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(if (search-forward (nnmbox-article-string article) nil t)
(let (start stop)
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
(setq start (point))
(forward-line 1)
(or (and (re-search-forward
(concat "^" message-unix-mail-delimiter) nil t)
(forward-line -1))
(goto-char (point-max)))
(setq stop (point))
(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring nnmbox-mbox-buffer start stop)
(goto-char (point-min))
(while (looking-at "From ")
(delete-char 5)
(insert "X-From-Line: ")
(forward-line 1))
(if (numberp article)
(cons nnmbox-current-group article)
(nnmbox-article-group-number)))))))
(deffoo nnmbox-request-group (group &optional server dont-check)
(let ((active (cadr (assoc group nnmbox-group-alist))))
(cond
((or (null active)
(null (nnmbox-possibly-change-newsgroup group server)))
(nnheader-report 'nnmbox "No such group: %s" group))
(dont-check
(nnheader-report 'nnmbox "Selected group %s" group)
(nnheader-insert ""))
(t
(nnheader-report 'nnmbox "Selected group %s" group)
(nnheader-insert "211 %d %d %d %s\n"
(1+ (- (cdr active) (car active)))
(car active) (cdr active) group)))))
(deffoo nnmbox-request-scan (&optional group server)
(nnmbox-read-mbox)
(nnmail-get-new-mail
'nnmbox
(lambda ()
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(save-buffer)))
nnmbox-mbox-file group
(lambda ()
(save-excursion
(let ((in-buf (current-buffer)))
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-max))
(insert-buffer-substring in-buf)))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
(deffoo nnmbox-close-group (group &optional server)
t)
(deffoo nnmbox-request-list (&optional server)
(save-excursion
(nnmail-find-file nnmbox-active-file)
(setq nnmbox-group-alist (nnmail-get-active))))
(deffoo nnmbox-request-newgroups (date &optional server)
(nnmbox-request-list server))
(deffoo nnmbox-request-list-newsgroups (&optional server)
(nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
(deffoo nnmbox-request-expire-articles
(articles newsgroup &optional server force)
(nnmbox-possibly-change-newsgroup newsgroup server)
(let* ((is-old t)
rest)
(nnmail-activate 'nnmbox)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(while (and articles is-old)
(goto-char (point-min))
(if (search-forward (nnmbox-article-string (car articles)) nil t)
(if (setq is-old
(nnmail-expired-article-p
newsgroup
(buffer-substring
(point) (progn (end-of-line) (point))) force))
(progn
(nnheader-message 5 "Deleting article %d in %s..."
(car articles) newsgroup)
(nnmbox-delete-mail))
(setq rest (cons (car articles) rest))))
(setq articles (cdr articles)))
(save-buffer)
;; Find the lowest active article in this group.
(let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
(goto-char (point-min))
(while (and (not (search-forward
(nnmbox-article-string (car active)) nil t))
(<= (car active) (cdr active)))
(setcar active (1+ (car active)))
(goto-char (point-min))))
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
(nconc rest articles))))
(deffoo nnmbox-request-move-article
(article group server accept-form &optional last)
(nnmbox-possibly-change-newsgroup group server)
(let ((buf (get-buffer-create " *nnmbox move*"))
result)
(and
(nnmbox-request-article article group server)
(save-excursion
(set-buffer buf)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(insert-buffer-substring nntp-server-buffer)
(goto-char (point-min))
(while (re-search-forward
"^X-Gnus-Newsgroup:"
(save-excursion (search-forward "\n\n" nil t) (point)) t)
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
(setq result (eval accept-form))
(kill-buffer buf)
result)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(if (search-forward (nnmbox-article-string article) nil t)
(nnmbox-delete-mail))
(and last (save-buffer))))
result))
(deffoo nnmbox-request-accept-article (group &optional server last)
(nnmbox-possibly-change-newsgroup group server)
(nnmail-check-syntax)
(let ((buf (current-buffer))
result)
(goto-char (point-min))
(if (looking-at "X-From-Line: ")
(replace-match "From ")
(insert "From nobody " (current-time-string) "\n"))
(and
(nnmail-activate 'nnmbox)
(progn
(set-buffer buf)
(goto-char (point-min))
(search-forward "\n\n" nil t)
(forward-line -1)
(while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
(delete-region (point) (progn (forward-line 1) (point))))
(setq result (nnmbox-save-mail (and (stringp group) group))))
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-max))
(insert-buffer-substring buf)
(and last (save-buffer))
result)
(nnmail-save-active nnmbox-group-alist nnmbox-active-file))
(car result)))
(deffoo nnmbox-request-replace-article (article group buffer)
(nnmbox-possibly-change-newsgroup group)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(if (not (search-forward (nnmbox-article-string article) nil t))
nil
(nnmbox-delete-mail t t)
(insert-buffer-substring buffer)
(save-buffer)
t)))
(deffoo nnmbox-request-delete-group (group &optional force server)
(nnmbox-possibly-change-newsgroup group server)
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
;; Delete all articles in this group.
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
found)
(while (search-forward ident nil t)
(setq found t)
(nnmbox-delete-mail))
(and found (save-buffer)))))
;; Remove the group from all structures.
(setq nnmbox-group-alist
(delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
nnmbox-current-group nil)
;; Save the active file.
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
t)
(deffoo nnmbox-request-rename-group (group new-name &optional server)
(nnmbox-possibly-change-newsgroup group server)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(goto-char (point-min))
(let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
(new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
found)
(while (search-forward ident nil t)
(replace-match new-ident t t)
(setq found t))
(and found (save-buffer))))
(let ((entry (assoc group nnmbox-group-alist)))
(and entry (setcar entry new-name))
(setq nnmbox-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnmbox-group-alist nnmbox-active-file)
t))
;;; Internal functions.
;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
;; delimiter line.
(defun nnmbox-delete-mail (&optional force leave-delim)
;; Delete the current X-Gnus-Newsgroup line.
(or force
(delete-region
(progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
;; Beginning of the article.
(save-excursion
(save-restriction
(narrow-to-region
(save-excursion
(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
(if leave-delim (progn (forward-line 1) (point))
(match-beginning 0)))
(progn
(forward-line 1)
(or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
nil t)
(if (and (not (bobp)) leave-delim)
(progn (forward-line -2) (point))
(match-beginning 0)))
(point-max))))
(goto-char (point-min))
;; Only delete the article if no other groups owns it as well.
(if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
(delete-region (point-min) (point-max))))))
(defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
(when (and server
(not (nnmbox-server-opened server)))
(nnmbox-open-server server))
(if (or (not nnmbox-mbox-buffer)
(not (buffer-name nnmbox-mbox-buffer)))
(save-excursion
(set-buffer (setq nnmbox-mbox-buffer
(nnheader-find-file-noselect
nnmbox-mbox-file nil 'raw)))
(buffer-disable-undo (current-buffer))))
(if (not nnmbox-group-alist)
(nnmail-activate 'nnmbox))
(if newsgroup
(if (assoc newsgroup nnmbox-group-alist)
(setq nnmbox-current-group newsgroup))
t))
(defun nnmbox-article-string (article)
(if (numberp article)
(concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
(int-to-string article) " ")
(concat "\nMessage-ID: " article)))
(defun nnmbox-article-group-number ()
(save-excursion
(goto-char (point-min))
(and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
nil t)
(cons (buffer-substring (match-beginning 1) (match-end 1))
(string-to-int
(buffer-substring (match-beginning 2) (match-end 2)))))))
(defun nnmbox-save-mail (&optional group)
"Called narrowed to an article."
(let* ((nnmail-split-methods
(if group (list (list group "")) nnmail-split-methods))
(group-art (nreverse (nnmail-article-group 'nnmbox-active-number)))
(delim (concat "^" message-unix-mail-delimiter)))
(goto-char (point-min))
;; This might come from somewhere else.
(unless (looking-at delim)
(insert "From nobody " (current-time-string) "\n")
(goto-char (point-min)))
;; Quote all "From " lines in the article.
(forward-line 1)
(while (re-search-forward delim nil t)
(beginning-of-line)
(insert "> "))
(nnmail-insert-lines)
(nnmail-insert-xref group-art)
(nnmbox-insert-newsgroup-line group-art)
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnmbox-prepare-save-mail-hook)
group-art))
(defun nnmbox-insert-newsgroup-line (group-art)
(save-excursion
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(progn
(forward-char -1)
(while group-art
(insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
(caar group-art) (cdar group-art)
(current-time-string)))
(setq group-art (cdr group-art)))))
t))
(defun nnmbox-active-number (group)
;; Find the next article number in GROUP.
(let ((active (cadr (assoc group nnmbox-group-alist))))
(if active
(setcdr active (1+ (cdr active)))
;; This group is new, so we create a new entry for it.
;; This might be a bit naughty... creating groups on the drop of
;; a hat, but I don't know...
(setq nnmbox-group-alist (cons (list group (setq active (cons 1 1)))
nnmbox-group-alist)))
(cdr active)))
(defun nnmbox-read-mbox ()
(nnmail-activate 'nnmbox)
(if (not (file-exists-p nnmbox-mbox-file))
(write-region 1 1 nnmbox-mbox-file t 'nomesg))
(if (and nnmbox-mbox-buffer
(buffer-name nnmbox-mbox-buffer)
(save-excursion
(set-buffer nnmbox-mbox-buffer)
(= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
()
(save-excursion
(let ((delim (concat "^" message-unix-mail-delimiter))
(alist nnmbox-group-alist)
start end number)
(set-buffer (setq nnmbox-mbox-buffer
(nnheader-find-file-noselect
nnmbox-mbox-file nil 'raw)))
(buffer-disable-undo (current-buffer))
;; Go through the group alist and compare against
;; the mbox file.
(while alist
(goto-char (point-max))
(when (and (re-search-backward
(format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
(caar alist)) nil t)
(>= (setq number
(string-to-number
(buffer-substring
(match-beginning 1) (match-end 1))))
(cdadar alist)))
(setcdr (cadar alist) (1+ number)))
(setq alist (cdr alist)))
(goto-char (point-min))
(while (re-search-forward delim nil t)
(setq start (match-beginning 0))
(if (not (search-forward "\nX-Gnus-Newsgroup: "
(save-excursion
(setq end
(or
(and
(re-search-forward delim nil t)
(match-beginning 0))
(point-max))))
t))
(save-excursion
(save-restriction
(narrow-to-region start end)
(nnmbox-save-mail))))
(goto-char end))))))
(provide 'nnmbox)
;;; nnmbox.el ends here

520
lisp/nnmh.el
View file

@ -1,520 +0,0 @@
;;; nnmh.el --- mhspool access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
;; For an overview of what the interface functions do, please see the
;; Gnus sources.
;;; Code:
(require 'nnheader)
(require 'nnmail)
(require 'gnus)
(require 'nnoo)
(eval-and-compile (require 'cl))
(nnoo-declare nnmh)
(defvoo nnmh-directory message-directory
"*Mail spool directory.")
(defvoo nnmh-get-new-mail t
"*If non-nil, nnmh will check the incoming mail file and split the mail.")
(defvoo nnmh-prepare-save-mail-hook nil
"*Hook run narrowed to an article before saving.")
(defvoo nnmh-be-safe nil
"*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
(defconst nnmh-version "nnmh 1.0"
"nnmh version.")
(defvoo nnmh-current-directory nil
"Current news group directory.")
(defvoo nnmh-status-string "")
(defvoo nnmh-group-alist nil)
;;; Interface functions.
(nnoo-define-basics nnmh)
(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let* ((file nil)
(number (length articles))
(large (and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)))
(count 0)
beg article)
(nnmh-possibly-change-directory newsgroup server)
;; We don't support fetching by Message-ID.
(if (stringp (car articles))
'headers
(while articles
(when (and (file-exists-p
(setq file (concat (file-name-as-directory
nnmh-current-directory)
(int-to-string
(setq article (pop articles))))))
(not (file-directory-p file)))
(insert (format "221 %d Article retrieved.\n" article))
(setq beg (point))
(nnheader-insert-head file)
(goto-char beg)
(if (search-forward "\n\n" nil t)
(forward-char -1)
(goto-char (point-max))
(insert "\n\n"))
(insert ".\n")
(delete-region (point) (point-max)))
(setq count (1+ count))
(and large
(zerop (% count 20))
(message "nnmh: Receiving headers... %d%%"
(/ (* count 100) number))))
(and large (message "nnmh: Receiving headers...done"))
(nnheader-fold-continuation-lines)
'headers))))
(deffoo nnmh-open-server (server &optional defs)
(nnoo-change-server 'nnmh server defs)
(when (not (file-exists-p nnmh-directory))
(condition-case ()
(make-directory nnmh-directory t)
(error t)))
(cond
((not (file-exists-p nnmh-directory))
(nnmh-close-server)
(nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
((not (file-directory-p (file-truename nnmh-directory)))
(nnmh-close-server)
(nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))
(t
(nnheader-report 'nnmh "Opened server %s using directory %s"
server nnmh-directory)
t)))
(deffoo nnmh-request-article (id &optional newsgroup server buffer)
(nnmh-possibly-change-directory newsgroup server)
(let ((file (if (stringp id)
nil
(concat nnmh-current-directory (int-to-string id))))
(nntp-server-buffer (or buffer nntp-server-buffer)))
(and (stringp file)
(file-exists-p file)
(not (file-directory-p file))
(save-excursion (nnmail-find-file file))
(string-to-int (file-name-nondirectory file)))))
(deffoo nnmh-request-group (group &optional server dont-check)
(let ((pathname (nnmail-group-pathname group nnmh-directory))
dir)
(cond
((not (file-directory-p pathname))
(nnheader-report
'nnmh "Can't select group (no such directory): %s" group))
(t
(setq nnmh-current-directory pathname)
(and nnmh-get-new-mail
nnmh-be-safe
(nnmh-update-gnus-unreads group))
(cond
(dont-check
(nnheader-report 'nnmh "Selected group %s" group)
t)
(t
;; Re-scan the directory if it's on a foreign system.
(nnheader-re-read-dir pathname)
(setq dir
(sort
(mapcar (lambda (name) (string-to-int name))
(directory-files pathname nil "^[0-9]+$" t))
'<))
(cond
(dir
(nnheader-report 'nnmh "Selected group %s" group)
(nnheader-insert
"211 %d %d %d %s\n" (length dir) (car dir)
(progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
group))
(t
(nnheader-report 'nnmh "Empty group %s" group)
(nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
(deffoo nnmh-request-scan (&optional group server)
(nnmail-get-new-mail 'nnmh nil nnmh-directory group))
(deffoo nnmh-request-list (&optional server dir)
(nnheader-insert "")
(let ((nnmh-toplev
(or dir (file-truename (file-name-as-directory nnmh-directory)))))
(nnmh-request-list-1 nnmh-toplev))
(setq nnmh-group-alist (nnmail-get-active))
t)
(defvar nnmh-toplev)
(defun nnmh-request-list-1 (dir)
(setq dir (expand-file-name dir))
;; Recurse down all directories.
(let ((dirs (and (file-readable-p dir)
(> (nth 1 (file-attributes (file-chase-links dir))) 2)
(directory-files dir t nil t)))
dir)
;; Recurse down directories.
(while (setq dir (pop dirs))
(when (and (not (member (file-name-nondirectory dir) '("." "..")))
(file-directory-p dir)
(file-readable-p dir))
(nnmh-request-list-1 dir))))
;; For each directory, generate an active file line.
(unless (string= (expand-file-name nnmh-toplev) dir)
(let ((files (mapcar
(lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))))
(when files
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-max))
(insert
(format
"%s %d %d y\n"
(progn
(string-match
(regexp-quote
(file-truename (file-name-as-directory
(expand-file-name nnmh-toplev)))) dir)
(nnheader-replace-chars-in-string
(substring dir (match-end 0)) ?/ ?.))
(apply 'max files)
(apply 'min files)))))))
t)
(deffoo nnmh-request-newgroups (date &optional server)
(nnmh-request-list server))
(deffoo nnmh-request-expire-articles (articles newsgroup &optional server force)
(nnmh-possibly-change-directory newsgroup server)
(let* ((active-articles
(mapcar
(function
(lambda (name)
(string-to-int name)))
(directory-files nnmh-current-directory nil "^[0-9]+$" t)))
(is-old t)
article rest mod-time)
(nnmail-activate 'nnmh)
(while (and articles is-old)
(setq article (concat nnmh-current-directory
(int-to-string (car articles))))
(if (setq mod-time (nth 5 (file-attributes article)))
(if (and (nnmh-deletable-article-p newsgroup (car articles))
(setq is-old
(nnmail-expired-article-p newsgroup mod-time force)))
(progn
(nnheader-message 5 "Deleting article %s in %s..."
article newsgroup)
(condition-case ()
(funcall nnmail-delete-file-function article)
(file-error
(nnheader-message 1 "Couldn't delete article %s in %s"
article newsgroup)
(setq rest (cons (car articles) rest)))))
(setq rest (cons (car articles) rest))))
(setq articles (cdr articles)))
(message "")
(nconc rest articles)))
(deffoo nnmh-close-group (group &optional server)
t)
(deffoo nnmh-request-move-article
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnmh move*"))
result)
(and
(nnmh-deletable-article-p group article)
(nnmh-request-article article group server)
(save-excursion
(set-buffer buf)
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
(progn
(nnmh-possibly-change-directory group server)
(condition-case ()
(funcall nnmail-delete-file-function
(concat nnmh-current-directory (int-to-string article)))
(file-error nil))))
result))
(deffoo nnmh-request-accept-article (group &optional server last noinsert)
(nnmh-possibly-change-directory group server)
(nnmail-check-syntax)
(if (stringp group)
(and
(nnmail-activate 'nnmh)
;; We trick the choosing function into believing that only one
;; group is available.
(let ((nnmail-split-methods (list (list group ""))))
(car (nnmh-save-mail noinsert))))
(and
(nnmail-activate 'nnmh)
(car (nnmh-save-mail noinsert)))))
(deffoo nnmh-request-replace-article (article group buffer)
(nnmh-possibly-change-directory group)
(save-excursion
(set-buffer buffer)
(nnmh-possibly-create-directory group)
(condition-case ()
(progn
(write-region
(point-min) (point-max)
(concat nnmh-current-directory (int-to-string article))
nil (if (nnheader-be-verbose 5) nil 'nomesg))
t)
(error nil))))
(deffoo nnmh-request-create-group (group &optional server)
(nnmail-activate 'nnmh)
(or (assoc group nnmh-group-alist)
(let (active)
(setq nnmh-group-alist (cons (list group (setq active (cons 1 0)))
nnmh-group-alist))
(nnmh-possibly-create-directory group)
(nnmh-possibly-change-directory group server)
(let ((articles (mapcar
(lambda (file)
(string-to-int file))
(directory-files
nnmh-current-directory nil "^[0-9]+$"))))
(and articles
(progn
(setcar active (apply 'min articles))
(setcdr active (apply 'max articles)))))))
t)
(deffoo nnmh-request-delete-group (group &optional force server)
(nnmh-possibly-change-directory group server)
;; Delete all articles in GROUP.
(if (not force)
() ; Don't delete the articles.
(let ((articles (directory-files nnmh-current-directory t "^[0-9]+$")))
(while articles
(and (file-writable-p (car articles))
(progn
(nnheader-message 5 "Deleting article %s in %s..."
(car articles) group)
(funcall nnmail-delete-file-function (car articles))))
(setq articles (cdr articles))))
;; Try to delete the directory itself.
(condition-case ()
(delete-directory nnmh-current-directory)
(error nil)))
;; Remove the group from all structures.
(setq nnmh-group-alist
(delq (assoc group nnmh-group-alist) nnmh-group-alist)
nnmh-current-directory nil)
t)
(deffoo nnmh-request-rename-group (group new-name &optional server)
(nnmh-possibly-change-directory group server)
;; Rename directory.
(and (file-writable-p nnmh-current-directory)
(condition-case ()
(progn
(rename-file
(directory-file-name nnmh-current-directory)
(directory-file-name
(nnmail-group-pathname new-name nnmh-directory)))
t)
(error nil))
;; That went ok, so we change the internal structures.
(let ((entry (assoc group nnmh-group-alist)))
(and entry (setcar entry new-name))
(setq nnmh-current-directory nil)
t)))
;;; Internal functions.
(defun nnmh-possibly-change-directory (newsgroup &optional server)
(when (and server
(not (nnmh-server-opened server)))
(nnmh-open-server server))
(if newsgroup
(let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)))
(if (file-directory-p pathname)
(setq nnmh-current-directory pathname)
(error "No such newsgroup: %s" newsgroup)))))
(defun nnmh-possibly-create-directory (group)
(let (dir dirs)
(setq dir (nnmail-group-pathname group nnmh-directory))
(while (not (file-directory-p dir))
(setq dirs (cons dir dirs))
(setq dir (file-name-directory (directory-file-name dir))))
(while dirs
(if (make-directory (directory-file-name (car dirs)))
(error "Could not create directory %s" (car dirs)))
(nnheader-message 5 "Creating mail directory %s" (car dirs))
(setq dirs (cdr dirs)))))
(defun nnmh-save-mail (&optional noinsert)
"Called narrowed to an article."
(let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number))))
(unless noinsert
(nnmail-insert-lines)
(nnmail-insert-xref group-art))
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnmh-prepare-save-mail-hook)
(goto-char (point-min))
(while (looking-at "From ")
(replace-match "X-From-Line: ")
(forward-line 1))
;; We save the article in all the newsgroups it belongs in.
(let ((ga group-art)
first)
(while ga
(nnmh-possibly-create-directory (caar ga))
(let ((file (concat (nnmail-group-pathname
(caar ga) nnmh-directory)
(int-to-string (cdar ga)))))
(if first
;; It was already saved, so we just make a hard link.
(funcall nnmail-crosspost-link-function first file t)
;; Save the article.
(write-region (point-min) (point-max) file nil nil)
(setq first file)))
(setq ga (cdr ga))))
group-art))
(defun nnmh-active-number (group)
"Compute the next article number in GROUP."
(let ((active (cadr (assoc group nnmh-group-alist))))
;; The group wasn't known to nnmh, so we just create an active
;; entry for it.
(or active
(progn
(setq active (cons 1 0))
(setq nnmh-group-alist (cons (list group active) nnmh-group-alist))))
(setcdr active (1+ (cdr active)))
(while (file-exists-p
(concat (nnmail-group-pathname group nnmh-directory)
(int-to-string (cdr active))))
(setcdr active (1+ (cdr active))))
(cdr active)))
(defun nnmh-update-gnus-unreads (group)
;; Go through the .nnmh-articles file and compare with the actual
;; articles in this folder. The articles that are "new" will be
;; marked as unread by Gnus.
(let* ((dir nnmh-current-directory)
(files (sort (mapcar (function (lambda (name) (string-to-int name)))
(directory-files nnmh-current-directory
nil "^[0-9]+$" t)) '<))
(nnmh-file (concat dir ".nnmh-articles"))
new articles)
;; Load the .nnmh-articles file.
(if (file-exists-p nnmh-file)
(setq articles
(let (nnmh-newsgroup-articles)
(condition-case nil (load nnmh-file nil t t) (error nil))
nnmh-newsgroup-articles)))
;; Add all new articles to the `new' list.
(let ((art files))
(while art
(if (not (assq (car art) articles)) (setq new (cons (car art) new)))
(setq art (cdr art))))
;; Remove all deleted articles.
(let ((art articles))
(while art
(if (not (memq (caar art) files))
(setq articles (delq (car art) articles)))
(setq art (cdr art))))
;; Check whether the highest-numbered articles really are the ones
;; that Gnus thinks they are by looking at the time-stamps.
(let ((art articles))
(while (and art
(not (equal
(nth 5 (file-attributes
(concat dir (int-to-string (caar art)))))
(cdar art))))
(setq articles (delq (car art) articles))
(setq new (cons (caar art) new))
(setq art (cdr art))))
;; Go through all the new articles and add them, and their
;; time-stamps to the list.
(let ((n new))
(while n
(setq articles
(cons (cons
(car n)
(nth 5 (file-attributes
(concat dir (int-to-string (car n))))))
articles))
(setq n (cdr n))))
;; Make Gnus mark all new articles as unread.
(or (zerop (length new))
(gnus-make-articles-unread
(gnus-group-prefixed-name group (list 'nnmh ""))
(setq new (sort new '<))))
;; Sort the article list with highest numbers first.
(setq articles (sort articles (lambda (art1 art2)
(> (car art1) (car art2)))))
;; Finally write this list back to the .nnmh-articles file.
(save-excursion
(set-buffer (get-buffer-create "*nnmh out*"))
(insert ";; Gnus article active file for " group "\n\n")
(insert "(setq nnmh-newsgroup-articles '")
(insert (prin1-to-string articles) ")\n")
(write-region (point-min) (point-max) nnmh-file nil 'nomesg)
(kill-buffer (current-buffer)))))
(defun nnmh-deletable-article-p (group article)
"Say whether ARTICLE in GROUP can be deleted."
(let ((path (concat nnmh-current-directory (int-to-string article))))
(and (file-writable-p path)
(or (not nnmail-keep-last-article)
(not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
article))))))
(provide 'nnmh)
;;; nnmh.el ends here

764
lisp/nnml.el
View file

@ -1,764 +0,0 @@
;;; nnml.el --- mail spool access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
;; For an overview of what the interface functions do, please see the
;; Gnus sources.
;;; Code:
(require 'nnheader)
(require 'nnmail)
(require 'nnoo)
(require 'cl)
(nnoo-declare nnml)
(defvoo nnml-directory message-directory
"Mail spool directory.")
(defvoo nnml-active-file
(concat (file-name-as-directory nnml-directory) "active")
"Mail active file.")
(defvoo nnml-newsgroups-file
(concat (file-name-as-directory nnml-directory) "newsgroups")
"Mail newsgroups description file.")
(defvoo nnml-get-new-mail t
"If non-nil, nnml will check the incoming mail file and split the mail.")
(defvoo nnml-nov-is-evil nil
"If non-nil, Gnus will never generate and use nov databases for mail groups.
Using nov databases will speed up header fetching considerably.
This variable shouldn't be flipped much. If you have, for some reason,
set this to t, and want to set it to nil again, you should always run
the `nnml-generate-nov-databases' command. The function will go
through all nnml directories and generate nov databases for them
all. This may very well take some time.")
(defvoo nnml-prepare-save-mail-hook nil
"Hook run narrowed to an article before saving.")
(defvoo nnml-inhibit-expiry nil
"If non-nil, inhibit expiry.")
(defconst nnml-version "nnml 1.0"
"nnml version.")
(defvoo nnml-nov-file-name ".overview")
(defvoo nnml-current-directory nil)
(defvoo nnml-current-group nil)
(defvoo nnml-status-string "")
(defvoo nnml-nov-buffer-alist nil)
(defvoo nnml-group-alist nil)
(defvoo nnml-active-timestamp nil)
(defvoo nnml-article-file-alist nil)
(defvoo nnml-generate-active-function 'nnml-generate-active-info)
;;; Interface functions.
(nnoo-define-basics nnml)
(deffoo nnml-retrieve-headers (sequence &optional newsgroup server fetch-old)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((file nil)
(number (length sequence))
(count 0)
beg article)
(if (stringp (car sequence))
'headers
(nnml-possibly-change-directory newsgroup server)
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(nnheader-article-to-file-alist nnml-current-directory)))
(if (nnml-retrieve-headers-with-nov sequence fetch-old)
'nov
(while sequence
(setq article (car sequence))
(setq file
(concat nnml-current-directory
(or (cdr (assq article nnml-article-file-alist))
"")))
(if (and (file-exists-p file)
(not (file-directory-p file)))
(progn
(insert (format "221 %d Article retrieved.\n" article))
(setq beg (point))
(nnheader-insert-head file)
(goto-char beg)
(if (search-forward "\n\n" nil t)
(forward-char -1)
(goto-char (point-max))
(insert "\n\n"))
(insert ".\n")
(delete-region (point) (point-max))))
(setq sequence (cdr sequence))
(setq count (1+ count))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(zerop (% count 20))
(nnheader-message 6 "nnml: Receiving headers... %d%%"
(/ (* count 100) number))))
(and (numberp nnmail-large-newsgroup)
(> number nnmail-large-newsgroup)
(nnheader-message 6 "nnml: Receiving headers...done"))
(nnheader-fold-continuation-lines)
'headers)))))
(deffoo nnml-open-server (server &optional defs)
(nnoo-change-server 'nnml server defs)
(when (not (file-exists-p nnml-directory))
(condition-case ()
(make-directory nnml-directory t)
(error t)))
(cond
((not (file-exists-p nnml-directory))
(nnml-close-server)
(nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory))
((not (file-directory-p (file-truename nnml-directory)))
(nnml-close-server)
(nnheader-report 'nnml "Not a directory: %s" nnml-directory))
(t
(nnheader-report 'nnml "Opened server %s using directory %s"
server nnml-directory)
t)))
(deffoo nnml-request-article (id &optional newsgroup server buffer)
(nnml-possibly-change-directory newsgroup server)
(let* ((nntp-server-buffer (or buffer nntp-server-buffer))
file path gpath group-num)
(if (stringp id)
(when (and (setq group-num (nnml-find-group-number id))
(setq file (cdr
(assq (cdr group-num)
(nnheader-article-to-file-alist
(setq gpath
(nnmail-group-pathname
(car group-num)
nnml-directory)))))))
(setq path (concat gpath (int-to-string (cdr group-num)))))
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(nnheader-article-to-file-alist nnml-current-directory)))
(when (setq file (cdr (assq id nnml-article-file-alist)))
(setq path (concat nnml-current-directory file))))
(cond
((not path)
(nnheader-report 'nnml "No such article: %s" id))
((not (file-exists-p path))
(nnheader-report 'nnml "No such file: %s" path))
((file-directory-p path)
(nnheader-report 'nnml "File is a directory: %s" path))
((not (save-excursion (nnmail-find-file path)))
(nnheader-report 'nnml "Couldn't read file: %s" path))
(t
(nnheader-report 'nnml "Article %s retrieved" id)
;; We return the article number.
(cons newsgroup (string-to-int (file-name-nondirectory path)))))))
(deffoo nnml-request-group (group &optional server dont-check)
(cond
((not (nnml-possibly-change-directory group server))
(nnheader-report 'nnml "Invalid group (no such directory)"))
((not (file-directory-p nnml-current-directory))
(nnheader-report 'nnml "%s is not a directory" nnml-current-directory))
(dont-check
(nnheader-report 'nnml "Group %s selected" group)
t)
(t
(nnmail-activate 'nnml)
(let ((active (nth 1 (assoc group nnml-group-alist))))
(if (not active)
(nnheader-report 'nnml "No such group: %s" group)
(nnheader-report 'nnml "Selected group %s" group)
(nnheader-insert "211 %d %d %d %s\n"
(max (1+ (- (cdr active) (car active))) 0)
(car active) (cdr active) group))))))
(deffoo nnml-request-scan (&optional group server)
(setq nnml-article-file-alist nil)
(nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group))
(deffoo nnml-close-group (group &optional server)
(setq nnml-article-file-alist nil)
t)
(deffoo nnml-request-create-group (group &optional server)
(nnmail-activate 'nnml)
(or (assoc group nnml-group-alist)
(let (active)
(setq nnml-group-alist (cons (list group (setq active (cons 1 0)))
nnml-group-alist))
(nnml-possibly-create-directory group)
(nnml-possibly-change-directory group server)
(let ((articles
(nnheader-directory-articles nnml-current-directory )))
(and articles
(progn
(setcar active (apply 'min articles))
(setcdr active (apply 'max articles)))))
(nnmail-save-active nnml-group-alist nnml-active-file)))
t)
(deffoo nnml-request-list (&optional server)
(save-excursion
(nnmail-find-file nnml-active-file)
(setq nnml-group-alist (nnmail-get-active))))
(deffoo nnml-request-newgroups (date &optional server)
(nnml-request-list server))
(deffoo nnml-request-list-newsgroups (&optional server)
(save-excursion
(nnmail-find-file nnml-newsgroups-file)))
(deffoo nnml-request-expire-articles (articles newsgroup &optional server force)
(nnml-possibly-change-directory newsgroup server)
(let* ((active-articles
(nnheader-directory-articles nnml-current-directory))
(is-old t)
article rest mod-time number)
(nnmail-activate 'nnml)
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(nnheader-article-to-file-alist nnml-current-directory)))
(while (and articles is-old)
(setq article (concat nnml-current-directory
(int-to-string
(setq number (pop articles)))))
(when (setq mod-time (nth 5 (file-attributes article)))
(if (and (nnml-deletable-article-p newsgroup number)
(setq is-old
(nnmail-expired-article-p newsgroup mod-time force
nnml-inhibit-expiry)))
(progn
(nnheader-message 5 "Deleting article %s in %s..."
article newsgroup)
(condition-case ()
(funcall nnmail-delete-file-function article)
(file-error
(push number rest)))
(setq active-articles (delq number active-articles))
(nnml-nov-delete-article newsgroup number))
(push number rest))))
(let ((active (nth 1 (assoc newsgroup nnml-group-alist))))
(when active
(setcar active (or (and active-articles
(apply 'min active-articles))
(1+ (cdr active)))))
(nnmail-save-active nnml-group-alist nnml-active-file))
(nnml-save-nov)
(message "")
(nconc rest articles)))
(deffoo nnml-request-move-article
(article group server accept-form &optional last)
(let ((buf (get-buffer-create " *nnml move*"))
result)
(nnml-possibly-change-directory group server)
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(nnheader-article-to-file-alist nnml-current-directory)))
(and
(nnml-deletable-article-p group article)
(nnml-request-article article group server)
(save-excursion
(set-buffer buf)
(insert-buffer-substring nntp-server-buffer)
(setq result (eval accept-form))
(kill-buffer (current-buffer))
result)
(progn
(nnml-possibly-change-directory group server)
(condition-case ()
(funcall nnmail-delete-file-function
(concat nnml-current-directory
(int-to-string article)))
(file-error nil))
(nnml-nov-delete-article group article)
(and last (nnml-save-nov))))
result))
(deffoo nnml-request-accept-article (group &optional server last)
(nnml-possibly-change-directory group server)
(nnmail-check-syntax)
(let (result)
(if (stringp group)
(and
(nnmail-activate 'nnml)
;; We trick the choosing function into believing that only one
;; group is available.
(let ((nnmail-split-methods (list (list group ""))))
(setq result (car (nnml-save-mail))))
(progn
(nnmail-save-active nnml-group-alist nnml-active-file)
(and last (nnml-save-nov))))
(and
(nnmail-activate 'nnml)
(setq result (car (nnml-save-mail)))
(progn
(nnmail-save-active nnml-group-alist nnml-active-file)
(and last (nnml-save-nov)))))
result))
(deffoo nnml-request-replace-article (article group buffer)
(nnml-possibly-change-directory group)
(save-excursion
(set-buffer buffer)
(nnml-possibly-create-directory group)
(let ((chars (nnmail-insert-lines))
(art (concat (int-to-string article) "\t"))
headers)
(when (condition-case ()
(progn
(write-region
(point-min) (point-max)
(concat nnml-current-directory (int-to-string article))
nil (if (nnheader-be-verbose 5) nil 'nomesg))
t)
(error nil))
(setq headers (nnml-parse-head chars article))
;; Replace the NOV line in the NOV file.
(save-excursion
(set-buffer (nnml-open-nov group))
(goto-char (point-min))
(if (or (looking-at art)
(search-forward (concat "\n" art) nil t))
;; Delete the old NOV line.
(delete-region (progn (beginning-of-line) (point))
(progn (forward-line 1) (point)))
;; The line isn't here, so we have to find out where
;; we should insert it. (This situation should never
;; occur, but one likes to make sure...)
(while (and (looking-at "[0-9]+\t")
(< (string-to-int
(buffer-substring
(match-beginning 0) (match-end 0)))
article)
(zerop (forward-line 1)))))
(beginning-of-line)
(nnheader-insert-nov headers)
(nnml-save-nov)
t)))))
(deffoo nnml-request-delete-group (group &optional force server)
(nnml-possibly-change-directory group server)
(when force
;; Delete all articles in GROUP.
(let ((articles
(directory-files
nnml-current-directory t
(concat nnheader-numerical-short-files
"\\|" (regexp-quote nnml-nov-file-name) "$")))
article)
(while articles
(setq article (pop articles))
(when (file-writable-p article)
(nnheader-message 5 "Deleting article %s in %s..." article group)
(funcall nnmail-delete-file-function article))))
;; Try to delete the directory itself.
(condition-case ()
(delete-directory nnml-current-directory)
(error nil)))
;; Remove the group from all structures.
(setq nnml-group-alist
(delq (assoc group nnml-group-alist) nnml-group-alist)
nnml-current-group nil
nnml-current-directory nil)
;; Save the active file.
(nnmail-save-active nnml-group-alist nnml-active-file)
t)
(deffoo nnml-request-rename-group (group new-name &optional server)
(nnml-possibly-change-directory group server)
;; Rename directory.
(and (file-writable-p nnml-current-directory)
(condition-case ()
(let ((parent
(file-name-directory
(directory-file-name
(nnmail-group-pathname new-name nnml-directory)))))
(unless (file-exists-p parent)
(make-directory parent t))
(rename-file
(directory-file-name nnml-current-directory)
(directory-file-name
(nnmail-group-pathname new-name nnml-directory)))
t)
(error nil))
;; That went ok, so we change the internal structures.
(let ((entry (assoc group nnml-group-alist)))
(and entry (setcar entry new-name))
(setq nnml-current-directory nil
nnml-current-group nil)
;; Save the new group alist.
(nnmail-save-active nnml-group-alist nnml-active-file)
t)))
;;; Internal functions.
(defun nnml-deletable-article-p (group article)
"Say whether ARTICLE in GROUP can be deleted."
(let (file path)
(when (setq file (cdr (assq article nnml-article-file-alist)))
(setq path (concat nnml-current-directory file))
(and (file-writable-p path)
(or (not nnmail-keep-last-article)
(not (eq (cdr (nth 1 (assoc group nnml-group-alist)))
article)))))))
;; Find an article number in the current group given the Message-ID.
(defun nnml-find-group-number (id)
(save-excursion
(set-buffer (get-buffer-create " *nnml id*"))
(buffer-disable-undo (current-buffer))
(let ((alist nnml-group-alist)
number)
;; We want to look through all .overview files, but we want to
;; start with the one in the current directory. It seems most
;; likely that the article we are looking for is in that group.
(if (setq number (nnml-find-id nnml-current-group id))
(cons nnml-current-group number)
;; It wasn't there, so we look through the other groups as well.
(while (and (not number)
alist)
(or (string= (caar alist) nnml-current-group)
(setq number (nnml-find-id (caar alist) id)))
(or number
(setq alist (cdr alist))))
(and number
(cons (caar alist) number))))))
(defun nnml-find-id (group id)
(erase-buffer)
(let ((nov (concat (nnmail-group-pathname group nnml-directory)
nnml-nov-file-name))
number found)
(when (file-exists-p nov)
(insert-file-contents nov)
(while (and (not found)
(search-forward id nil t)) ; We find the ID.
;; And the id is in the fourth field.
(if (search-backward
"\t" (save-excursion (beginning-of-line) (point)) t 4)
(progn
(beginning-of-line)
(setq found t)
;; We return the article number.
(setq number
(condition-case ()
(read (current-buffer))
(error nil))))))
number)))
(defun nnml-retrieve-headers-with-nov (articles &optional fetch-old)
(if (or gnus-nov-is-evil nnml-nov-is-evil)
nil
(let ((first (car articles))
(last (progn (while (cdr articles) (setq articles (cdr articles)))
(car articles)))
(nov (concat nnml-current-directory nnml-nov-file-name)))
(when (file-exists-p nov)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-file-contents nov)
(if (and fetch-old
(not (numberp fetch-old)))
t ; Don't remove anything.
(if fetch-old
(setq first (max 1 (- first fetch-old))))
(goto-char (point-min))
(while (and (not (eobp)) (> first (read (current-buffer))))
(forward-line 1))
(beginning-of-line)
(if (not (eobp)) (delete-region 1 (point)))
(while (and (not (eobp)) (>= last (read (current-buffer))))
(forward-line 1))
(beginning-of-line)
(if (not (eobp)) (delete-region (point) (point-max)))
t))))))
(defun nnml-possibly-change-directory (group &optional server)
(when (and server
(not (nnml-server-opened server)))
(nnml-open-server server))
(when group
(let ((pathname (nnmail-group-pathname group nnml-directory)))
(when (not (equal pathname nnml-current-directory))
(setq nnml-current-directory pathname
nnml-current-group group
nnml-article-file-alist nil))))
t)
(defun nnml-possibly-create-directory (group)
(let (dir dirs)
(setq dir (nnmail-group-pathname group nnml-directory))
(while (not (file-directory-p dir))
(setq dirs (cons dir dirs))
(setq dir (file-name-directory (directory-file-name dir))))
(while dirs
(make-directory (directory-file-name (car dirs)))
(nnheader-message 5 "Creating mail directory %s" (car dirs))
(setq dirs (cdr dirs)))))
(defun nnml-save-mail ()
"Called narrowed to an article."
(let ((group-art (nreverse (nnmail-article-group 'nnml-active-number)))
chars headers)
(setq chars (nnmail-insert-lines))
(nnmail-insert-xref group-art)
(run-hooks 'nnmail-prepare-save-mail-hook)
(run-hooks 'nnml-prepare-save-mail-hook)
(goto-char (point-min))
(while (looking-at "From ")
(replace-match "X-From-Line: ")
(forward-line 1))
;; We save the article in all the newsgroups it belongs in.
(let ((ga group-art)
first)
(while ga
(nnml-possibly-create-directory (caar ga))
(let ((file (concat (nnmail-group-pathname
(caar ga) nnml-directory)
(int-to-string (cdar ga)))))
(if first
;; It was already saved, so we just make a hard link.
(funcall nnmail-crosspost-link-function first file t)
;; Save the article.
(write-region (point-min) (point-max) file nil
(if (nnheader-be-verbose 5) nil 'nomesg))
(setq first file)))
(setq ga (cdr ga))))
;; Generate a nov line for this article. We generate the nov
;; line after saving, because nov generation destroys the
;; header.
(setq headers (nnml-parse-head chars))
;; Output the nov line to all nov databases that should have it.
(let ((ga group-art))
(while ga
(nnml-add-nov (caar ga) (cdar ga) headers)
(setq ga (cdr ga))))
group-art))
(defun nnml-active-number (group)
"Compute the next article number in GROUP."
(let ((active (cadr (assoc group nnml-group-alist))))
;; The group wasn't known to nnml, so we just create an active
;; entry for it.
(unless active
;; Perhaps the active file was corrupt? See whether
;; there are any articles in this group.
(nnml-possibly-create-directory group)
(nnml-possibly-change-directory group)
(unless nnml-article-file-alist
(setq nnml-article-file-alist
(sort
(nnheader-article-to-file-alist nnml-current-directory)
(lambda (a1 a2) (< (car a1) (car a2))))))
(setq active
(if nnml-article-file-alist
(cons (caar nnml-article-file-alist)
(caar (last nnml-article-file-alist)))
(cons 1 0)))
(setq nnml-group-alist (cons (list group active) nnml-group-alist)))
(setcdr active (1+ (cdr active)))
(while (file-exists-p
(concat (nnmail-group-pathname group nnml-directory)
(int-to-string (cdr active))))
(setcdr active (1+ (cdr active))))
(cdr active)))
(defun nnml-add-nov (group article headers)
"Add a nov line for the GROUP base."
(save-excursion
(set-buffer (nnml-open-nov group))
(goto-char (point-max))
(mail-header-set-number headers article)
(nnheader-insert-nov headers)))
(defsubst nnml-header-value ()
(buffer-substring (match-end 0) (progn (end-of-line) (point))))
(defun nnml-parse-head (chars &optional number)
"Parse the head of the current buffer."
(save-excursion
(save-restriction
(goto-char (point-min))
(narrow-to-region
(point)
(1- (or (search-forward "\n\n" nil t) (point-max))))
;; Fold continuation lines.
(goto-char (point-min))
(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
(replace-match " " t t))
;; Remove any tabs; they are too confusing.
(subst-char-in-region (point-min) (point-max) ?\t ? )
(let ((headers (nnheader-parse-head t)))
(mail-header-set-chars headers chars)
(mail-header-set-number headers number)
headers))))
(defun nnml-open-nov (group)
(or (cdr (assoc group nnml-nov-buffer-alist))
(let ((buffer (find-file-noselect
(concat (nnmail-group-pathname group nnml-directory)
nnml-nov-file-name))))
(save-excursion
(set-buffer buffer)
(buffer-disable-undo (current-buffer)))
(setq nnml-nov-buffer-alist
(cons (cons group buffer) nnml-nov-buffer-alist))
buffer)))
(defun nnml-save-nov ()
(save-excursion
(while nnml-nov-buffer-alist
(when (buffer-name (cdar nnml-nov-buffer-alist))
(set-buffer (cdar nnml-nov-buffer-alist))
(and (buffer-modified-p)
(write-region
1 (point-max) (buffer-file-name) nil 'nomesg))
(set-buffer-modified-p nil)
(kill-buffer (current-buffer)))
(setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist)))))
;;;###autoload
(defun nnml-generate-nov-databases ()
"Generate nov databases in all nnml directories."
(interactive)
;; Read the active file to make sure we don't re-use articles
;; numbers in empty groups.
(nnmail-activate 'nnml)
(nnml-open-server (or (nnoo-current-server 'nnml) ""))
(setq nnml-directory (expand-file-name nnml-directory))
;; Recurse down the directories.
(nnml-generate-nov-databases-1 nnml-directory)
;; Save the active file.
(nnmail-save-active nnml-group-alist nnml-active-file))
(defun nnml-generate-nov-databases-1 (dir)
(setq dir (file-name-as-directory dir))
;; We descend recursively
(let ((dirs (directory-files dir t nil t))
dir)
(while dirs
(setq dir (pop dirs))
(when (and (not (member (file-name-nondirectory dir) '("." "..")))
(file-directory-p dir))
(nnml-generate-nov-databases-1 dir))))
;; Do this directory.
(let ((files (sort
(mapcar
(lambda (name) (string-to-int name))
(directory-files dir nil "^[0-9]+$" t))
'<)))
(when files
(funcall nnml-generate-active-function dir)
;; Generate the nov file.
(nnml-generate-nov-file dir files))))
(defvar files)
(defun nnml-generate-active-info (dir)
;; Update the active info for this group.
(let ((group (nnheader-file-to-group
(directory-file-name dir) nnml-directory)))
(setq nnml-group-alist
(delq (assoc group nnml-group-alist) nnml-group-alist))
(push (list group
(cons (car files)
(let ((f files))
(while (cdr f) (setq f (cdr f)))
(car f))))
nnml-group-alist)))
(defun nnml-generate-nov-file (dir files)
(let* ((dir (file-name-as-directory dir))
(nov (concat dir nnml-nov-file-name))
(nov-buffer (get-buffer-create " *nov*"))
nov-line chars file headers)
(save-excursion
;; Init the nov buffer.
(set-buffer nov-buffer)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(set-buffer nntp-server-buffer)
;; Delete the old NOV file.
(when (file-exists-p nov)
(funcall nnmail-delete-file-function nov))
(while files
(unless (file-directory-p
(setq file (concat dir (int-to-string (car files)))))
(erase-buffer)
(insert-file-contents file)
(narrow-to-region
(goto-char (point-min))
(progn
(search-forward "\n\n" nil t)
(setq chars (- (point-max) (point)))
(max 1 (1- (point)))))
(when (and (not (= 0 chars)) ; none of them empty files...
(not (= (point-min) (point-max))))
(goto-char (point-min))
(setq headers (nnml-parse-head chars (car files)))
(save-excursion
(set-buffer nov-buffer)
(goto-char (point-max))
(nnheader-insert-nov headers)))
(widen))
(setq files (cdr files)))
(save-excursion
(set-buffer nov-buffer)
(write-region 1 (point-max) (expand-file-name nov) nil
'nomesg)
(kill-buffer (current-buffer))))))
(defun nnml-nov-delete-article (group article)
(save-excursion
(set-buffer (nnml-open-nov group))
(goto-char (point-min))
(if (re-search-forward (concat "^" (int-to-string article) "\t") nil t)
(delete-region (match-beginning 0) (progn (forward-line 1) (point))))
t))
(provide 'nnml)
;;; nnml.el ends here

251
lisp/nnoo.el
View file

@ -1,251 +0,0 @@
;;; nnoo.el --- OO Gnus Backends
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
(defvar nnoo-definition-alist nil)
(defvar nnoo-state-alist nil)
(defmacro defvoo (var init &optional doc &rest map)
"The same as `defvar', only takes list of variables to MAP to."
`(prog1
,(if doc
`(defvar ,var ,init ,doc)
`(defvar ,var ,init))
(nnoo-define ',var ',map)))
(put 'defvoo 'lisp-indent-function 2)
(put 'defvoo 'lisp-indent-hook 2)
(put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map))
(defmacro deffoo (func args &rest forms)
"The same as `defun', only register FUNC."
`(prog1
(defun ,func ,args ,@forms)
(nnoo-register-function ',func)))
(put 'deffoo 'lisp-indent-function 2)
(put 'deffoo 'lisp-indent-hook 2)
(put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body))
(defun nnoo-register-function (func)
(let ((funcs (nthcdr 3 (assoc (nnoo-backend func)
nnoo-definition-alist))))
(unless funcs
(error "%s belongs to a backend that hasn't been declared" func))
(setcar funcs (cons func (car funcs)))))
(defmacro nnoo-declare (backend &rest parents)
`(eval-and-compile
(push (list ',backend
(mapcar (lambda (p) (list p)) ',parents)
nil nil)
nnoo-definition-alist)))
(put 'nnoo-declare 'lisp-indent-function 1)
(put 'nnoo-declare 'lisp-indent-hook 1)
(defun nnoo-parents (backend)
(nth 1 (assoc backend nnoo-definition-alist)))
(defun nnoo-variables (backend)
(nth 2 (assoc backend nnoo-definition-alist)))
(defun nnoo-functions (backend)
(nth 3 (assoc backend nnoo-definition-alist)))
(defmacro nnoo-import (backend &rest imports)
`(nnoo-import-1 ',backend ',imports))
(put 'nnoo-import 'lisp-indent-function 1)
(put 'nnoo-import 'lisp-indent-hook 1)
(defun nnoo-import-1 (backend imports)
(let ((call-function
(if (symbolp (car imports)) (pop imports) 'nnoo-parent-function))
imp functions function)
(while (setq imp (pop imports))
(setq functions
(or (cdr imp)
(nnoo-functions (car imp))))
(while functions
(unless (fboundp (setq function
(nnoo-symbol backend (nnoo-rest-symbol
(car functions)))))
(eval `(deffoo ,function (&rest args)
(,call-function ',backend ',(car functions) args))))
(pop functions)))))
(defun nnoo-parent-function (backend function args)
(let* ((pbackend (nnoo-backend function)))
(nnoo-change-server pbackend (nnoo-current-server backend)
(cdr (assq pbackend (nnoo-parents backend))))
(apply function args)))
(defun nnoo-execute (backend function &rest args)
"Execute FUNCTION on behalf of BACKEND."
(let* ((pbackend (nnoo-backend function)))
(nnoo-change-server pbackend (nnoo-current-server backend)
(cdr (assq pbackend (nnoo-parents backend))))
(apply function args)))
(defmacro nnoo-map-functions (backend &rest maps)
`(nnoo-map-functions-1 ',backend ',maps))
(put 'nnoo-map-functions 'lisp-indent-function 1)
(put 'nnoo-map-functions 'lisp-indent-hook 1)
(defun nnoo-map-functions-1 (backend maps)
(let (m margs i)
(while (setq m (pop maps))
(setq i 0
margs nil)
(while (< i (length (cdr m)))
(if (numberp (nth i (cdr m)))
(push `(nth ,i args) margs)
(push (nth i (cdr m)) margs))
(incf i))
(eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m)))
(&rest args)
(nnoo-parent-function ',backend ',(car m)
,(cons 'list (nreverse margs))))))))
(defun nnoo-backend (symbol)
(string-match "^[^-]+-" (symbol-name symbol))
(intern (substring (symbol-name symbol) 0 (1- (match-end 0)))))
(defun nnoo-rest-symbol (symbol)
(string-match "^[^-]+-" (symbol-name symbol))
(intern (substring (symbol-name symbol) (match-end 0))))
(defun nnoo-symbol (backend symbol)
(intern (format "%s-%s" backend symbol)))
(defun nnoo-define (var map)
(let* ((backend (nnoo-backend var))
(def (assq backend nnoo-definition-alist))
(parents (nth 1 def)))
(unless def
(error "%s belongs to a backend that hasn't been declared." var))
(setcar (nthcdr 2 def)
(delq (assq var (nth 2 def)) (nth 2 def)))
(setcar (nthcdr 2 def)
(cons (cons var (symbol-value var))
(nth 2 def)))
(while map
(nconc (assq (nnoo-backend (car map)) parents)
(list (list (pop map) var))))))
(defun nnoo-change-server (backend server defs)
(let* ((bstate (cdr (assq backend nnoo-state-alist)))
(sdefs (assq backend nnoo-definition-alist))
(current (car bstate))
(parents (nnoo-parents backend))
state)
(unless bstate
(push (setq bstate (list backend nil))
nnoo-state-alist)
(pop bstate))
(if (equal server current)
t
(nnoo-push-server backend current)
(setq state (or (cdr (assoc server (cddr bstate)))
(nnoo-variables backend)))
(while state
(set (caar state) (cdar state))
(pop state))
(setcar bstate server)
(unless (cdr (assoc server (cddr bstate)))
(while defs
(set (caar defs) (cadar defs))
(pop defs)))
(while parents
(nnoo-change-server
(caar parents) server
(mapcar (lambda (def) (list (car def) (symbol-value (cadr def))))
(cdar parents)))
(pop parents))))
t)
(defun nnoo-push-server (backend current)
(let ((bstate (assq backend nnoo-state-alist))
(defs (nnoo-variables backend)))
;; Remove the old definition.
(setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate)))
(let (state)
(while defs
(push (cons (caar defs) (symbol-value (caar defs)))
state)
(pop defs))
(nconc bstate (list (cons current state))))))
(defun nnoo-current-server-p (backend server)
(equal (nnoo-current-server backend) server))
(defun nnoo-current-server (backend)
(nth 1 (assq backend nnoo-state-alist)))
(defun nnoo-close-server (backend &optional server)
(unless server
(setq server (nnoo-current-server backend)))
(when server
(let* ((bstate (cdr (assq backend nnoo-state-alist)))
(defs (assoc server (cdr bstate))))
(when bstate
(setcar bstate nil)
(setcdr bstate (delq defs (cdr bstate)))
(pop defs)
(while defs
(set (car (pop defs)) nil)))))
t)
(defun nnoo-close (backend)
(setq nnoo-state-alist
(delq (assq backend nnoo-state-alist)
nnoo-state-alist))
t)
(defun nnoo-status-message (backend server)
(nnheader-get-report backend))
(defun nnoo-server-opened (backend server)
(and (nnoo-current-server-p backend server)
nntp-server-buffer
(buffer-name nntp-server-buffer)))
(defmacro nnoo-define-basics (backend)
`(eval-and-compile
(nnoo-define-basics-1 ',backend)))
(defun nnoo-define-basics-1 (backend)
(let ((functions '(close-server server-opened status-message)))
(while functions
(eval `(deffoo ,(nnoo-symbol backend (car functions))
(&optional server)
(,(nnoo-symbol 'nnoo (pop functions)) ',backend server)))))
(eval `(deffoo ,(nnoo-symbol backend 'open-server)
(server &optional defs)
(nnoo-change-server ',backend server defs))))
(provide 'nnoo)
;;; nnoo.el ends here.

747
lisp/nnsoup.el
View file

@ -1,747 +0,0 @@
;;; nnsoup.el --- SOUP access for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'nnheader)
(require 'nnmail)
(require 'gnus-soup)
(require 'gnus-msg)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnsoup)
(defvoo nnsoup-directory "~/SOUP/"
"*SOUP packet directory.")
(defvoo nnsoup-tmp-directory "/tmp/"
"*Where nnsoup will store temporary files.")
(defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/")
"*Directory where outgoing packets will be composed.")
(defvoo nnsoup-replies-format-type ?n
"*Format of the replies packages.")
(defvoo nnsoup-replies-index-type ?n
"*Index type of the replies packages.")
(defvoo nnsoup-active-file (concat nnsoup-directory "active")
"Active file.")
(defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
"Format string command for packing a SOUP packet.
The SOUP files will be inserted where the %s is in the string.
This string MUST contain both %s and %d. The file number will be
inserted where %d appears.")
(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
"*Format string command for unpacking a SOUP packet.
The SOUP packet file name will be inserted at the %s.")
(defvoo nnsoup-packet-directory "~/"
"*Where nnsoup will look for incoming packets.")
(defvoo nnsoup-packet-regexp "Soupout"
"*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
(defconst nnsoup-version "nnsoup 0.0"
"nnsoup version.")
(defvoo nnsoup-status-string "")
(defvoo nnsoup-group-alist nil)
(defvoo nnsoup-current-prefix 0)
(defvoo nnsoup-replies-list nil)
(defvoo nnsoup-buffers nil)
(defvoo nnsoup-current-group nil)
(defvoo nnsoup-group-alist-touched nil)
;;; Interface functions.
(nnoo-define-basics nnsoup)
(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
(nnsoup-possibly-change-group group)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
(articles sequence)
(use-nov t)
useful-areas this-area-seq msg-buf)
(if (stringp (car sequence))
;; We don't support fetching by Message-ID.
'headers
;; We go through all the areas and find which files the
;; articles in SEQUENCE come from.
(while (and areas sequence)
;; Peel off areas that are below sequence.
(while (and areas (< (cdaar areas) (car sequence)))
(setq areas (cdr areas)))
(when areas
;; This is a useful area.
(push (car areas) useful-areas)
(setq this-area-seq nil)
;; We take note whether this MSG has a corresponding IDX
;; for later use.
(when (or (= (gnus-soup-encoding-index
(gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
(not (file-exists-p
(nnsoup-file
(gnus-soup-area-prefix (nth 1 (car areas)))))))
(setq use-nov nil))
;; We assign the portion of `sequence' that is relevant to
;; this MSG packet to this packet.
(while (and sequence (<= (car sequence) (cdaar areas)))
(push (car sequence) this-area-seq)
(setq sequence (cdr sequence)))
(setcar useful-areas (cons (nreverse this-area-seq)
(car useful-areas)))))
;; We now have a list of article numbers and corresponding
;; areas.
(setq useful-areas (nreverse useful-areas))
;; Two different approaches depending on whether all the MSG
;; files have corresponding IDX files. If they all do, we
;; simply return the relevant IDX files and let Gnus sort out
;; what lines are relevant. If some of the IDX files are
;; missing, we must return HEADs for all the articles.
(if use-nov
;; We have IDX files for all areas.
(progn
(while useful-areas
(goto-char (point-max))
(let ((b (point))
(number (car (nth 1 (car useful-areas))))
(index-buffer (nnsoup-index-buffer
(gnus-soup-area-prefix
(nth 2 (car useful-areas))))))
(when index-buffer
(insert-buffer-substring index-buffer)
(goto-char b)
;; We have to remove the index number entires and
;; insert article numbers instead.
(while (looking-at "[0-9]+")
(replace-match (int-to-string number) t t)
(incf number)
(forward-line 1))))
(setq useful-areas (cdr useful-areas)))
'nov)
;; We insert HEADs.
(while useful-areas
(setq articles (caar useful-areas)
useful-areas (cdr useful-areas))
(while articles
(when (setq msg-buf
(nnsoup-narrow-to-article
(car articles) (cdar useful-areas) 'head))
(goto-char (point-max))
(insert (format "221 %d Article retrieved.\n" (car articles)))
(insert-buffer-substring msg-buf)
(goto-char (point-max))
(insert ".\n"))
(setq articles (cdr articles))))
(nnheader-fold-continuation-lines)
'headers)))))
(deffoo nnsoup-open-server (server &optional defs)
(nnoo-change-server 'nnsoup server defs)
(when (not (file-exists-p nnsoup-directory))
(condition-case ()
(make-directory nnsoup-directory t)
(error t)))
(cond
((not (file-exists-p nnsoup-directory))
(nnsoup-close-server)
(nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
((not (file-directory-p (file-truename nnsoup-directory)))
(nnsoup-close-server)
(nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
(t
(nnsoup-read-active-file)
(nnheader-report 'nnsoup "Opened server %s using directory %s"
server nnsoup-directory)
t)))
(deffoo nnsoup-request-close ()
(nnsoup-write-active-file)
(nnsoup-write-replies)
(gnus-soup-save-areas)
;; Kill all nnsoup buffers.
(let (buffer)
(while nnsoup-buffers
(setq buffer (cdr (pop nnsoup-buffers)))
(and buffer
(buffer-name buffer)
(kill-buffer buffer))))
(setq nnsoup-group-alist nil
nnsoup-group-alist-touched nil
nnsoup-current-group nil
nnsoup-replies-list nil)
(nnoo-close-server 'nnoo)
t)
(deffoo nnsoup-request-article (id &optional newsgroup server buffer)
(nnsoup-possibly-change-group newsgroup)
(let (buf)
(save-excursion
(set-buffer (or buffer nntp-server-buffer))
(erase-buffer)
(when (and (not (stringp id))
(setq buf (nnsoup-narrow-to-article id)))
(insert-buffer-substring buf)
t))))
(deffoo nnsoup-request-group (group &optional server dont-check)
(nnsoup-possibly-change-group group)
(if dont-check
t
(let ((active (cadr (assoc group nnsoup-group-alist))))
(if (not active)
(nnheader-report 'nnsoup "No such group: %s" group)
(nnheader-insert
"211 %d %d %d %s\n"
(max (1+ (- (cdr active) (car active))) 0)
(car active) (cdr active) group)))))
(deffoo nnsoup-request-type (group &optional article)
(nnsoup-possibly-change-group group)
(if (not article)
'unknown
(let ((kind (gnus-soup-encoding-kind
(gnus-soup-area-encoding
(nth 1 (nnsoup-article-to-area
article nnsoup-current-group))))))
(cond ((= kind ?m) 'mail)
((= kind ?n) 'news)
(t 'unknown)))))
(deffoo nnsoup-close-group (group &optional server)
;; Kill all nnsoup buffers.
(let ((buffers nnsoup-buffers)
elem)
(while buffers
(when (equal (car (setq elem (pop buffers))) group)
(setq nnsoup-buffers (delq elem nnsoup-buffers))
(and (cdr elem) (buffer-name (cdr elem))
(kill-buffer (cdr elem))))))
t)
(deffoo nnsoup-request-list (&optional server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(unless nnsoup-group-alist
(nnsoup-read-active-file))
(let ((alist nnsoup-group-alist)
(standard-output (current-buffer))
entry)
(while (setq entry (pop alist))
(insert (car entry) " ")
(princ (cdadr entry))
(insert " ")
(princ (caadr entry))
(insert " y\n"))
t)))
(deffoo nnsoup-request-scan (group &optional server)
(nnsoup-unpack-packets))
(deffoo nnsoup-request-newgroups (date &optional server)
(nnsoup-request-list))
(deffoo nnsoup-request-list-newsgroups (&optional server)
nil)
(deffoo nnsoup-request-post (&optional server)
(nnsoup-store-reply "news")
t)
(deffoo nnsoup-request-mail (&optional server)
(nnsoup-store-reply "mail")
t)
(deffoo nnsoup-request-expire-articles (articles group &optional server force)
(nnsoup-possibly-change-group group)
(let* ((total-infolist (assoc group nnsoup-group-alist))
(active (cadr total-infolist))
(infolist (cddr total-infolist))
info range-list mod-time prefix)
(while infolist
(setq info (pop infolist)
range-list (gnus-uncompress-range (car info))
prefix (gnus-soup-area-prefix (nth 1 info)))
(when ;; All the articles in this file are marked for expiry.
(and (or (setq mod-time (nth 5 (file-attributes
(nnsoup-file prefix))))
(setq mod-time (nth 5 (file-attributes
(nnsoup-file prefix t)))))
(gnus-sublist-p articles range-list)
;; This file is old enough.
(nnmail-expired-article-p group mod-time force))
;; Ok, we delete this file.
(when (condition-case nil
(progn
(nnheader-message
5 "Deleting %s in group %s..." (nnsoup-file prefix)
group)
(when (file-exists-p (nnsoup-file prefix))
(delete-file (nnsoup-file prefix)))
(nnheader-message
5 "Deleting %s in group %s..." (nnsoup-file prefix t)
group)
(when (file-exists-p (nnsoup-file prefix t))
(delete-file (nnsoup-file prefix t)))
t)
(error nil))
(setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
(setq articles (gnus-sorted-complement articles range-list))))
(when (not mod-time)
(setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
(if (cddr total-infolist)
(setcar active (caaadr (cdr total-infolist)))
(setcar active (1+ (cdr active))))
(nnsoup-write-active-file t)
;; Return the articles that weren't expired.
articles))
;;; Internal functions
(defun nnsoup-possibly-change-group (group &optional force)
(if group
(setq nnsoup-current-group group)
t))
(defun nnsoup-read-active-file ()
(setq nnsoup-group-alist nil)
(when (file-exists-p nnsoup-active-file)
(condition-case ()
(load nnsoup-active-file t t t)
(error nil))
;; Be backwards compatible.
(when (and nnsoup-group-alist
(not (atom (caadar nnsoup-group-alist))))
(let ((alist nnsoup-group-alist)
entry e min max)
(while (setq e (cdr (setq entry (pop alist))))
(setq min (caaar e))
(while (cdr e)
(setq e (cdr e)))
(setq max (cdaar e))
(setcdr entry (cons (cons min max) (cdr entry)))))
(setq nnsoup-group-alist-touched t))
nnsoup-group-alist))
(defun nnsoup-write-active-file (&optional force)
(when (and nnsoup-group-alist
(or force
nnsoup-group-alist-touched))
(setq nnsoup-group-alist-touched nil)
(nnheader-temp-write nnsoup-active-file
(let ((standard-output (current-buffer)))
(prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
(insert "\n")
(prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
(insert "\n")))))
(defun nnsoup-next-prefix ()
"Return the next free prefix."
(let (prefix)
(while (or (file-exists-p
(nnsoup-file (setq prefix (int-to-string
nnsoup-current-prefix))))
(file-exists-p (nnsoup-file prefix t)))
(incf nnsoup-current-prefix))
(incf nnsoup-current-prefix)
prefix))
(defun nnsoup-read-areas ()
(save-excursion
(set-buffer nntp-server-buffer)
(let ((areas (gnus-soup-parse-areas (concat nnsoup-tmp-directory "AREAS")))
entry number area lnum cur-prefix file)
;; Go through all areas in the new AREAS file.
(while (setq area (pop areas))
;; Change the name to the permanent name and move the files.
(setq cur-prefix (nnsoup-next-prefix))
(message "Incorporating file %s..." cur-prefix)
(when (file-exists-p
(setq file (concat nnsoup-tmp-directory
(gnus-soup-area-prefix area) ".IDX")))
(rename-file file (nnsoup-file cur-prefix)))
(when (file-exists-p
(setq file (concat nnsoup-tmp-directory
(gnus-soup-area-prefix area) ".MSG")))
(rename-file file (nnsoup-file cur-prefix t))
(gnus-soup-set-area-prefix area cur-prefix)
;; Find the number of new articles in this area.
(setq number (nnsoup-number-of-articles area))
(if (not (setq entry (assoc (gnus-soup-area-name area)
nnsoup-group-alist)))
;; If this is a new area (group), we just add this info to
;; the group alist.
(push (list (gnus-soup-area-name area)
(cons 1 number)
(list (cons 1 number) area))
nnsoup-group-alist)
;; There are already articles in this group, so we add this
;; info to the end of the entry.
(nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
(+ lnum number))
area)))
(setcdr (cadr entry) (+ lnum number))))))
(nnsoup-write-active-file t)
(delete-file (concat nnsoup-tmp-directory "AREAS"))))
(defun nnsoup-number-of-articles (area)
(save-excursion
(cond
;; If the number is in the area info, we just return it.
((gnus-soup-area-number area)
(gnus-soup-area-number area))
;; If there is an index file, we just count the lines.
((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
(set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
(count-lines (point-min) (point-max)))
;; We do it the hard way - re-searching through the message
;; buffer.
(t
(set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
(goto-char (point-min))
(let ((regexp (nnsoup-header (gnus-soup-encoding-format
(gnus-soup-area-encoding area))))
(num 0))
(while (re-search-forward regexp nil t)
(setq num (1+ num)))
num)))))
(defun nnsoup-index-buffer (prefix &optional message)
(let* ((file (concat prefix (if message ".MSG" ".IDX")))
(buffer-name (concat " *nnsoup " file "*")))
(or (get-buffer buffer-name) ; File aready loaded.
(when (file-exists-p (concat nnsoup-directory file))
(save-excursion ; Load the file.
(set-buffer (get-buffer-create buffer-name))
(buffer-disable-undo (current-buffer))
(push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
(insert-file-contents (concat nnsoup-directory file))
(current-buffer))))))
(defun nnsoup-file (prefix &optional message)
(expand-file-name
(concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
(defun nnsoup-message-buffer (prefix)
(nnsoup-index-buffer prefix 'msg))
(defun nnsoup-unpack-packets ()
"Unpack all packets in `nnsoup-packet-directory'."
(let ((packets (directory-files
nnsoup-packet-directory t nnsoup-packet-regexp))
packet)
(while (setq packet (pop packets))
(message (format "nnsoup: unpacking %s..." packet))
(if (not (gnus-soup-unpack-packet
nnsoup-tmp-directory nnsoup-unpacker packet))
(message "Couldn't unpack %s" packet)
(delete-file packet)
(nnsoup-read-areas)
(message "Unpacking...done")))))
(defun nnsoup-narrow-to-article (article &optional area head)
(let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
(prefix (and area (gnus-soup-area-prefix (nth 1 area))))
(msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
beg end)
(when area
(save-excursion
(cond
;; There is no MSG file.
((null msg-buf)
nil)
;; We use the index file to find out where the article begins and ends.
((and (= (gnus-soup-encoding-index
(gnus-soup-area-encoding (nth 1 area)))
?c)
(file-exists-p (nnsoup-file prefix)))
(set-buffer (nnsoup-index-buffer prefix))
(widen)
(goto-char (point-min))
(forward-line (- article (caar area)))
(setq beg (read (current-buffer)))
(forward-line 1)
(if (looking-at "[0-9]+")
(progn
(setq end (read (current-buffer)))
(set-buffer msg-buf)
(widen)
(let ((format (gnus-soup-encoding-format
(gnus-soup-area-encoding (nth 1 area)))))
(goto-char end)
(if (or (= format ?n) (= format ?m))
(setq end (progn (forward-line -1) (point))))))
(set-buffer msg-buf))
(widen)
(narrow-to-region beg (or end (point-max))))
(t
(set-buffer msg-buf)
(widen)
(goto-char (point-min))
(let ((header (nnsoup-header
(gnus-soup-encoding-format
(gnus-soup-area-encoding (nth 1 area))))))
(re-search-forward header nil t (- article (caar area)))
(narrow-to-region
(match-beginning 0)
(if (re-search-forward header nil t)
(match-beginning 0)
(point-max))))))
(goto-char (point-min))
(if (not head)
()
(narrow-to-region
(point-min)
(if (search-forward "\n\n" nil t)
(1- (point))
(point-max))))
msg-buf))))
(defun nnsoup-header (format)
(cond
((= format ?n)
"^#! *rnews +[0-9]+ *$")
((= format ?m)
(concat "^" message-unix-mail-delimiter))
((= format ?M)
"^\^A\^A\^A\^A\n")
(t
(error "Unknown format: %c" format))))
;;;###autoload
(defun nnsoup-pack-replies ()
"Make an outbound package of SOUP replies."
(interactive)
;; Write all data buffers.
(gnus-soup-save-areas)
;; Write the active file.
(nnsoup-write-active-file)
;; Write the REPLIES file.
(nnsoup-write-replies)
;; Pack all these files into a SOUP packet.
(gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
(defun nnsoup-write-replies ()
"Write the REPLIES file."
(when nnsoup-replies-list
(gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
(setq nnsoup-replies-list nil)))
(defun nnsoup-article-to-area (article group)
"Return the area that ARTICLE in GROUP is located in."
(let ((areas (cddr (assoc group nnsoup-group-alist))))
(while (and areas (< (cdaar areas) article))
(setq areas (cdr areas)))
(and areas (car areas))))
(defvar nnsoup-old-functions
(list message-send-mail-function message-send-news-function))
;;;###autoload
(defun nnsoup-set-variables ()
"Use the SOUP methods for posting news and mailing mail."
(interactive)
(setq message-send-news-function 'nnsoup-request-post)
(setq message-send-mail-function 'nnsoup-request-mail))
;;;###autoload
(defun nnsoup-revert-variables ()
"Revert posting and mailing methods to the standard Emacs methods."
(interactive)
(setq message-send-mail-function (car nnsoup-old-functions))
(setq message-send-news-function (cadr nnsoup-old-functions)))
(defun nnsoup-store-reply (kind)
;; Mostly stolen from `message.el'.
(require 'mail-utils)
(let ((tembuf (generate-new-buffer " message temp"))
(case-fold-search nil)
(news (message-news-p))
(resend-to-addresses (mail-fetch-field "resent-to"))
delimline
(mailbuf (current-buffer)))
(unwind-protect
(save-excursion
(save-restriction
(message-narrow-to-headers)
(if (equal kind "mail")
(message-generate-headers message-required-mail-headers)
(message-generate-headers message-required-news-headers)))
(set-buffer tembuf)
(erase-buffer)
(insert-buffer-substring mailbuf)
;; Remove some headers.
(save-restriction
(message-narrow-to-headers)
;; Remove some headers.
(message-remove-header message-ignored-mail-headers t))
(goto-char (point-max))
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
(when (and news
(equal kind "mail")
(or (mail-fetch-field "cc")
(mail-fetch-field "to")))
(message-insert-courtesy-copy))
(let ((case-fold-search t))
;; Change header-delimiter to be what sendmail expects.
(goto-char (point-min))
(re-search-forward
(concat "^" (regexp-quote mail-header-separator) "\n"))
(replace-match "\n")
(backward-char 1)
(setq delimline (point-marker))
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
(when (eval message-mailer-swallows-blank-line)
(newline))
(let ((msg-buf
(gnus-soup-store
nnsoup-replies-directory
(nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
nnsoup-replies-index-type))
(num 0))
(when (and msg-buf (bufferp msg-buf))
(save-excursion
(set-buffer msg-buf)
(goto-char (point-min))
(while (re-search-forward "^#! *rnews" nil t)
(incf num)))
(message "Stored %d messages" num)))
(nnsoup-write-replies)
(kill-buffer tembuf))))))
(defun nnsoup-kind-to-prefix (kind)
(unless nnsoup-replies-list
(setq nnsoup-replies-list
(gnus-soup-parse-replies
(concat nnsoup-replies-directory "REPLIES"))))
(let ((replies nnsoup-replies-list))
(while (and replies
(not (string= kind (gnus-soup-reply-kind (car replies)))))
(setq replies (cdr replies)))
(if replies
(gnus-soup-reply-prefix (car replies))
(setq nnsoup-replies-list
(cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
kind
(format "%c%c%c"
nnsoup-replies-format-type
nnsoup-replies-index-type
(if (string= kind "news")
?n ?m)))
nnsoup-replies-list))
(gnus-soup-reply-prefix (car nnsoup-replies-list)))))
(defun nnsoup-make-active ()
"(Re-)create the SOUP active file."
(interactive)
(let ((files (sort (directory-files nnsoup-directory t "IDX$")
(lambda (f1 f2)
(< (progn (string-match "/\\([0-9]+\\)\\." f1)
(string-to-int (match-string 1 f1)))
(progn (string-match "/\\([0-9]+\\)\\." f2)
(string-to-int (match-string 1 f2)))))))
active group lines ident elem min)
(set-buffer (get-buffer-create " *nnsoup work*"))
(buffer-disable-undo (current-buffer))
(while files
(message "Doing %s..." (car files))
(erase-buffer)
(insert-file-contents (car files))
(goto-char (point-min))
(if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
(setq group "unknown")
(setq group (match-string 2)))
(setq lines (count-lines (point-min) (point-max)))
(setq ident (progn (string-match
"/\\([0-9]+\\)\\." (car files))
(substring
(car files) (match-beginning 1)
(match-end 1))))
(if (not (setq elem (assoc group active)))
(push (list group (cons 1 lines)
(list (cons 1 lines)
(vector ident group "ncm" "" lines)))
active)
(nconc elem
(list
(list (cons (1+ (setq min (cdadr elem)))
(+ min lines))
(vector ident group "ncm" "" lines))))
(setcdr (cadr elem) (+ min lines)))
(setq files (cdr files)))
(message "")
(setq nnsoup-group-alist active)
(nnsoup-write-active-file t)))
(defun nnsoup-delete-unreferenced-message-files ()
"Delete any *.MSG and *.IDX files that aren't known by nnsoup."
(interactive)
(let* ((known (apply 'nconc (mapcar
(lambda (ga)
(mapcar
(lambda (area)
(gnus-soup-area-prefix (cadr area)))
(cddr ga)))
nnsoup-group-alist)))
(regexp "\\.MSG$\\|\\.IDX$")
(files (directory-files nnsoup-directory nil regexp))
non-files file)
;; Find all files that aren't known by nnsoup.
(while (setq file (pop files))
(string-match regexp file)
(unless (member (substring file 0 (match-beginning 0)) known)
(push file non-files)))
;; Sort and delete the files.
(setq non-files (sort non-files 'string<))
(map-y-or-n-p "Delete file %s? "
(lambda (file) (delete-file (concat nnsoup-directory file)))
non-files)))
(provide 'nnsoup)
;;; nnsoup.el ends here

511
lisp/nnspool.el
View file

@ -1,511 +0,0 @@
;;; nnspool.el --- spool access for GNU Emacs
;; Copyright (C) 1988,89,90,93,94,95,96 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'nnheader)
(require 'nntp)
(require 'timezone)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnspool)
(defvoo nnspool-inews-program news-inews-program
"Program to post news.
This is most commonly `inews' or `injnews'.")
(defvoo nnspool-inews-switches '("-h" "-S")
"Switches for nnspool-request-post to pass to `inews' for posting news.
If you are using Cnews, you probably should set this variable to nil.")
(defvoo nnspool-spool-directory (file-name-as-directory news-path)
"Local news spool directory.")
(defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
"Local news nov directory.")
(defvoo nnspool-lib-dir "/usr/lib/news/"
"Where the local news library files are stored.")
(defvoo nnspool-active-file (concat nnspool-lib-dir "active")
"Local news active file.")
(defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
"Local news newsgroups file.")
(defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat")
"Local news distributions file.")
(defvoo nnspool-history-file (concat nnspool-lib-dir "history")
"Local news history file.")
(defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times")
"Local news active date file.")
(defvoo nnspool-large-newsgroup 50
"The number of the articles which indicates a large newsgroup.
If the number of the articles is greater than the value, verbose
messages will be shown to indicate the current status.")
(defvoo nnspool-nov-is-evil nil
"Non-nil means that nnspool will never return NOV lines instead of headers.")
(defconst nnspool-sift-nov-with-sed nil
"If non-nil, use sed to get the relevant portion from the overview file.
If nil, nnspool will load the entire file into a buffer and process it
there.")
(defvoo nnspool-rejected-article-hook nil
"*A hook that will be run when an article has been rejected by the server.")
(defconst nnspool-version "nnspool 2.0"
"Version numbers of this version of NNSPOOL.")
(defvoo nnspool-current-directory nil
"Current news group directory.")
(defvoo nnspool-current-group nil)
(defvoo nnspool-status-string "")
;;; Interface functions.
(nnoo-define-basics nnspool)
(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
"Retrieve the headers of ARTICLES."
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(when (nnspool-possibly-change-directory group)
(let* ((number (length articles))
(count 0)
(default-directory nnspool-current-directory)
(do-message (and (numberp nnspool-large-newsgroup)
(> number nnspool-large-newsgroup)))
file beg article ag)
(if (and (numberp (car articles))
(nnspool-retrieve-headers-with-nov articles fetch-old))
;; We successfully retrieved the NOV headers.
'nov
;; No NOV headers here, so we do it the hard way.
(while (setq article (pop articles))
(if (stringp article)
;; This is a Message-ID.
(setq ag (nnspool-find-id article)
file (and ag (nnspool-article-pathname
(car ag) (cdr ag)))
article (cdr ag))
;; This is an article in the current group.
(setq file (int-to-string article)))
;; Insert the head of the article.
(when (and file
(file-exists-p file))
(insert "221 ")
(princ article (current-buffer))
(insert " Article retrieved.\n")
(setq beg (point))
(inline (nnheader-insert-head file))
(goto-char beg)
(search-forward "\n\n" nil t)
(forward-char -1)
(insert ".\n")
(delete-region (point) (point-max)))
(and do-message
(zerop (% (incf count) 20))
(message "nnspool: Receiving headers... %d%%"
(/ (* count 100) number))))
(and do-message
(message "nnspool: Receiving headers...done"))
;; Fold continuation lines.
(nnheader-fold-continuation-lines)
'headers)))))
(deffoo nnspool-open-server (server &optional defs)
(nnoo-change-server 'nnspool server defs)
(cond
((not (file-exists-p nnspool-spool-directory))
(nnspool-close-server)
(nnheader-report 'nnspool "Spool directory doesn't exist: %s"
nnspool-spool-directory))
((not (file-directory-p
(directory-file-name
(file-truename nnspool-spool-directory))))
(nnspool-close-server)
(nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory))
((not (file-exists-p nnspool-active-file))
(nnheader-report 'nnspool "The active file doesn't exist: %s"
nnspool-active-file))
(t
(nnheader-report 'nnspool "Opened server %s using directory %s"
server nnspool-spool-directory)
t)))
(deffoo nnspool-request-article (id &optional group server buffer)
"Select article by message ID (or number)."
(nnspool-possibly-change-directory group)
(let ((nntp-server-buffer (or buffer nntp-server-buffer))
file ag)
(if (stringp id)
;; This is a Message-ID.
(when (setq ag (nnspool-find-id id))
(setq file (nnspool-article-pathname (car ag) (cdr ag))))
(setq file (nnspool-article-pathname nnspool-current-group id)))
(and file
(file-exists-p file)
(not (file-directory-p file))
(save-excursion (nnspool-find-file file))
;; We return the article number and group name.
(if (numberp id)
(cons nnspool-current-group id)
ag))))
(deffoo nnspool-request-body (id &optional group server)
"Select article body by message ID (or number)."
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
(when res
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (point-min) (point)))
res))))
(deffoo nnspool-request-head (id &optional group server)
"Select article head by message ID (or number)."
(nnspool-possibly-change-directory group)
(let ((res (nnspool-request-article id)))
(when res
(save-excursion
(set-buffer nntp-server-buffer)
(goto-char (point-min))
(when (search-forward "\n\n" nil t)
(delete-region (1- (point)) (point-max)))
(nnheader-fold-continuation-lines)))
res))
(deffoo nnspool-request-group (group &optional server dont-check)
"Select news GROUP."
(let ((pathname (nnspool-article-pathname group))
dir)
(if (not (file-directory-p pathname))
(nnheader-report
'nnspool "Invalid group name (no such directory): %s" group)
(setq nnspool-current-directory pathname)
(nnheader-report 'nnspool "Selected group %s" group)
(if dont-check
(progn
(nnheader-report 'nnspool "Selected group %s" group)
t)
;; Yes, completely empty spool directories *are* possible.
;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
(when (setq dir (directory-files pathname nil "^[0-9]+$" t))
(setq dir
(sort (mapcar (lambda (name) (string-to-int name)) dir) '<)))
(if dir
(nnheader-insert
"211 %d %d %d %s\n" (length dir) (car dir)
(progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
group)
(nnheader-report 'nnspool "Empty group %s" group)
(nnheader-insert "211 0 0 0 %s\n" group))))))
(deffoo nnspool-request-type (group &optional article)
'news)
(deffoo nnspool-close-group (group &optional server)
t)
(deffoo nnspool-request-list (&optional server)
"List active newsgroups."
(save-excursion
(or (nnspool-find-file nnspool-active-file)
(nnheader-report 'nnspool (nnheader-file-error nnspool-active-file)))))
(deffoo nnspool-request-list-newsgroups (&optional server)
"List newsgroups (defined in NNTP2)."
(save-excursion
(or (nnspool-find-file nnspool-newsgroups-file)
(nnheader-report 'nnspool (nnheader-file-error
nnspool-newsgroups-file)))))
(deffoo nnspool-request-list-distributions (&optional server)
"List distributions (defined in NNTP2)."
(save-excursion
(or (nnspool-find-file nnspool-distributions-file)
(nnheader-report 'nnspool (nnheader-file-error
nnspool-distributions-file)))))
;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
(deffoo nnspool-request-newgroups (date &optional server)
"List groups created after DATE."
(if (nnspool-find-file nnspool-active-times-file)
(save-excursion
;; Find the last valid line.
(goto-char (point-max))
(while (and (not (looking-at
"\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] "))
(zerop (forward-line -1))))
(let ((seconds (nnspool-seconds-since-epoch date))
groups)
;; Go through lines and add the latest groups to a list.
(while (and (looking-at "\\([^ ]+\\) +[0-9]+ ")
(progn
;; We insert a .0 to make the list reader
;; interpret the number as a float. It is far
;; too big to be stored in a lisp integer.
(goto-char (1- (match-end 0)))
(insert ".0")
(> (progn
(goto-char (match-end 1))
(read (current-buffer)))
seconds))
(setq groups (cons (buffer-substring
(match-beginning 1) (match-end 1))
groups))
(zerop (forward-line -1))))
(erase-buffer)
(while groups
(insert (car groups) " 0 0 y\n")
(setq groups (cdr groups))))
t)
nil))
(deffoo nnspool-request-post (&optional server)
"Post a new news in current buffer."
(save-excursion
(let* ((process-connection-type nil) ; t bugs out on Solaris
(inews-buffer (generate-new-buffer " *nnspool post*"))
(proc
(condition-case err
(apply 'start-process "*nnspool inews*" inews-buffer
nnspool-inews-program nnspool-inews-switches)
(error
(nnheader-report 'nnspool "inews error: %S" err)))))
(if (not proc)
;; The inews program failed.
()
(nnheader-report 'nnspool "")
(set-process-sentinel proc 'nnspool-inews-sentinel)
(process-send-region proc (point-min) (point-max))
;; We slap a condition-case around this, because the process may
;; have exited already...
(condition-case nil
(process-send-eof proc)
(error nil))
t))))
;;; Internal functions.
(defun nnspool-inews-sentinel (proc status)
(save-excursion
(set-buffer (process-buffer proc))
(goto-char (point-min))
(if (or (zerop (buffer-size))
(search-forward "spooled" nil t))
(kill-buffer (current-buffer))
;; Make status message by folding lines.
(while (re-search-forward "[ \t\n]+" nil t)
(replace-match " " t t))
(nnheader-report 'nnspool "%s" (buffer-string))
(message "nnspool: %s" nnspool-status-string)
(ding)
(run-hooks 'nnspool-rejected-article-hook))))
(defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old)
(if (or gnus-nov-is-evil nnspool-nov-is-evil)
nil
(let ((nov (nnheader-group-pathname
nnspool-current-group nnspool-nov-directory ".overview"))
(arts articles)
last)
(if (not (file-exists-p nov))
()
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if nnspool-sift-nov-with-sed
(nnspool-sift-nov-with-sed articles nov)
(insert-file-contents nov)
(if (and fetch-old
(not (numberp fetch-old)))
t ; We want all the headers.
(condition-case ()
(progn
;; First we find the first wanted line.
(nnspool-find-nov-line
(if fetch-old (max 1 (- (car articles) fetch-old))
(car articles)))
(delete-region (point-min) (point))
;; Then we find the last wanted line.
(if (nnspool-find-nov-line
(progn (while (cdr articles)
(setq articles (cdr articles)))
(car articles)))
(forward-line 1))
(delete-region (point) (point-max))
;; If the buffer is empty, this wasn't very successful.
(unless (zerop (buffer-size))
;; We check what the last article number was.
;; The NOV file may be out of sync with the articles
;; in the group.
(forward-line -1)
(setq last (read (current-buffer)))
(if (= last (car articles))
;; Yup, it's all there.
t
;; Perhaps not. We try to find the missing articles.
(while (and arts
(<= last (car arts)))
(pop arts))
;; The articles in `arts' are missing from the buffer.
(while arts
(nnspool-insert-nov-head (pop arts)))
t)))
;; The NOV file was corrupted.
(error nil)))))))))
(defun nnspool-insert-nov-head (article)
"Read the head of ARTICLE, convert to NOV headers, and insert."
(save-excursion
(let ((cur (current-buffer))
buf)
(setq buf (nnheader-set-temp-buffer " *nnspool head*"))
(when (nnheader-insert-head
(nnspool-article-pathname nnspool-current-group article))
(nnheader-insert-article-line article)
(let ((headers (nnheader-parse-head)))
(set-buffer cur)
(goto-char (point-max))
(nnheader-insert-nov headers)))
(kill-buffer buf))))
(defun nnspool-find-nov-line (article)
(let ((max (point-max))
(min (goto-char (point-min)))
(cur (current-buffer))
(prev (point-min))
num found)
(while (not found)
(goto-char (/ (+ max min) 2))
(beginning-of-line)
(if (or (= (point) prev)
(eobp))
(setq found t)
(setq prev (point))
(cond ((> (setq num (read cur)) article)
(setq max (point)))
((< num article)
(setq min (point)))
(t
(setq found 'yes)))))
;; Now we may have found the article we're looking for, or we
;; may be somewhere near it.
(when (and (not (eq found 'yes))
(not (eq num article)))
(setq found (point))
(while (and (< (point) max)
(or (not (numberp num))
(< num article)))
(forward-line 1)
(setq found (point))
(or (eobp)
(= (setq num (read cur)) article)))
(unless (eq num article)
(goto-char found)))
(beginning-of-line)
(eq num article)))
(defun nnspool-sift-nov-with-sed (articles file)
(let ((first (car articles))
(last (progn (while (cdr articles) (setq articles (cdr articles)))
(car articles))))
(call-process "awk" nil t nil
(format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}"
(1- first) (1+ last))
file)))
;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle).
;; Find out what group an article identified by a Message-ID is in.
(defun nnspool-find-id (id)
(save-excursion
(set-buffer (get-buffer-create " *nnspool work*"))
(buffer-disable-undo (current-buffer))
(erase-buffer)
(condition-case ()
(call-process "grep" nil t nil (regexp-quote id) nnspool-history-file)
(error nil))
(goto-char (point-min))
(prog1
(if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]")
(cons (match-string 1) (string-to-int (match-string 2))))
(kill-buffer (current-buffer)))))
(defun nnspool-find-file (file)
"Insert FILE in server buffer safely."
(set-buffer nntp-server-buffer)
(erase-buffer)
(condition-case ()
(progn (nnheader-insert-file-contents-literally file) t)
(file-error nil)))
(defun nnspool-possibly-change-directory (group)
(if (not group)
t
(let ((pathname (nnspool-article-pathname group)))
(if (file-directory-p pathname)
(setq nnspool-current-directory pathname
nnspool-current-group group)
(nnheader-report 'nnspool "No such newsgroup: %s" group)))))
(defun nnspool-article-pathname (group &optional article)
"Find the path for GROUP."
(nnheader-group-pathname group nnspool-spool-directory article))
(defun nnspool-seconds-since-epoch (date)
(let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
(timezone-parse-date date)))
(ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
(timezone-parse-time
(aref (timezone-parse-date date) 3))))
(unix (encode-time (nth 2 ttime) (nth 1 ttime) (nth 0 ttime)
(nth 2 tdate) (nth 1 tdate) (nth 0 tdate)
(nth 4 tdate))))
(+ (* (car unix) 65536.0)
(cadr unix))))
(provide 'nnspool)
;;; nnspool.el ends here

1336
lisp/nntp.el
View file

File diff suppressed because it is too large Load diff

409
lisp/nnvirtual.el
View file

@ -1,409 +0,0 @@
;;; nnvirtual.el --- virtual newsgroups access for Gnus
;; Copyright (C) 1994,95,96 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; The other access methods (nntp, nnspool, etc) are general news
;; access methods. This module relies on Gnus and can not be used
;; separately.
;;; Code:
(require 'nntp)
(require 'nnheader)
(require 'gnus)
(require 'nnoo)
(eval-when-compile (require 'cl))
(nnoo-declare nnvirtual)
(defvoo nnvirtual-always-rescan nil
"*If non-nil, always scan groups for unread articles when entering a group.
If this variable is nil (which is the default) and you read articles
in a component group after the virtual group has been activated, the
read articles from the component group will show up when you enter the
virtual group.")
(defvoo nnvirtual-component-regexp nil
"*Regexp to match component groups.")
(defconst nnvirtual-version "nnvirtual 1.0")
(defvoo nnvirtual-current-group nil)
(defvoo nnvirtual-component-groups nil)
(defvoo nnvirtual-mapping nil)
(defvoo nnvirtual-status-string "")
(eval-and-compile
(autoload 'gnus-cache-articles-in-group "gnus-cache"))
;;; Interface functions.
(nnoo-define-basics nnvirtual)
(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
server fetch-old)
(when (nnvirtual-possibly-change-server server)
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(if (stringp (car articles))
'headers
(let ((vbuf (nnheader-set-temp-buffer
(get-buffer-create " *virtual headers*")))
(unfetched (mapcar (lambda (g) (list g))
nnvirtual-component-groups))
(system-name (system-name))
cgroup article result prefix)
(while articles
(setq article (assq (pop articles) nnvirtual-mapping))
(when (and (setq cgroup (cadr article))
(gnus-check-server
(gnus-find-method-for-group cgroup) t)
(gnus-request-group cgroup t))
(setq prefix (gnus-group-real-prefix cgroup))
(when (setq result (gnus-retrieve-headers
(list (caddr article)) cgroup nil))
(set-buffer nntp-server-buffer)
(if (zerop (buffer-size))
(nconc (assq cgroup unfetched) (list (caddr article)))
;; If we got HEAD headers, we convert them into NOV
;; headers. This is slow, inefficient and, come to think
;; of it, downright evil. So sue me. I couldn't be
;; bothered to write a header parse routine that could
;; parse a mixed HEAD/NOV buffer.
(when (eq result 'headers)
(nnvirtual-convert-headers))
(goto-char (point-min))
(while (not (eobp))
(delete-region
(point) (progn (read nntp-server-buffer) (point)))
(princ (car article) (current-buffer))
(beginning-of-line)
(looking-at
"[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
(goto-char (match-end 0))
(or (search-forward
"\t" (save-excursion (end-of-line) (point)) t)
(end-of-line))
(while (= (char-after (1- (point))) ? )
(forward-char -1)
(delete-char 1))
(if (eolp)
(progn
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(insert ?\t))
(insert "Xref: " system-name " " cgroup ":")
(princ (caddr article) (current-buffer))
(insert "\t"))
(insert "Xref: " system-name " " cgroup ":")
(princ (caddr article) (current-buffer))
(insert " ")
(if (not (string= "" prefix))
(while (re-search-forward
"[^ ]+:[0-9]+"
(save-excursion (end-of-line) (point)) t)
(save-excursion
(goto-char (match-beginning 0))
(insert prefix))))
(end-of-line)
(or (= (char-after (1- (point))) ?\t)
(insert ?\t)))
(forward-line 1))
(set-buffer vbuf)
(goto-char (point-max))
(insert-buffer-substring nntp-server-buffer)))))
;; In case some of the articles have expired or been
;; cancelled, we have to mark them as read in the
;; component group.
(while unfetched
(when (cdar unfetched)
(gnus-group-make-articles-read
(caar unfetched) (sort (cdar unfetched) '<)))
(setq unfetched (cdr unfetched)))
;; The headers are ready for reading, so they are inserted into
;; the nntp-server-buffer, which is where Gnus expects to find
;; them.
(prog1
(save-excursion
(set-buffer nntp-server-buffer)
(erase-buffer)
(insert-buffer-substring vbuf)
'nov)
(kill-buffer vbuf)))))))
(deffoo nnvirtual-request-article (article &optional group server buffer)
(when (and (nnvirtual-possibly-change-server server)
(numberp article))
(let* ((amap (assq article nnvirtual-mapping))
(cgroup (cadr amap)))
(cond
((not amap)
(nnheader-report 'nnvirtual "No such article: %s" article))
((not (gnus-check-group cgroup))
(nnheader-report
'nnvirtual "Can't open server where %s exists" cgroup))
((not (gnus-request-group cgroup t))
(nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
(t
(if buffer
(save-excursion
(set-buffer buffer)
(gnus-request-article-this-buffer (caddr amap) cgroup))
(gnus-request-article (caddr amap) cgroup)))))))
(deffoo nnvirtual-open-server (server &optional defs)
(unless (assq 'nnvirtual-component-regexp defs)
(push `(nnvirtual-component-regexp ,server)
defs))
(nnoo-change-server 'nnvirtual server defs)
(if nnvirtual-component-groups
t
(setq nnvirtual-mapping nil)
;; Go through the newsrc alist and find all component groups.
(let ((newsrc (cdr gnus-newsrc-alist))
group)
(while (setq group (car (pop newsrc)))
(when (string-match nnvirtual-component-regexp group) ; Match
;; Add this group to the list of component groups.
(setq nnvirtual-component-groups
(cons group (delete group nnvirtual-component-groups))))))
(if (not nnvirtual-component-groups)
(nnheader-report 'nnvirtual "No component groups: %s" server)
t)))
(deffoo nnvirtual-request-group (group &optional server dont-check)
(nnvirtual-possibly-change-server server)
(setq nnvirtual-component-groups
(delete (nnvirtual-current-group) nnvirtual-component-groups))
(cond
((null nnvirtual-component-groups)
(setq nnvirtual-current-group nil)
(nnheader-report 'nnvirtual "No component groups in %s" group))
(t
(unless dont-check
(nnvirtual-create-mapping))
(setq nnvirtual-current-group group)
(let ((len (length nnvirtual-mapping)))
(nnheader-insert "211 %d 1 %d %s\n" len len group)))))
(deffoo nnvirtual-request-type (group &optional article)
(if (not article)
'unknown
(let ((mart (assq article nnvirtual-mapping)))
(when mart
(gnus-request-type (cadr mart) (car mart))))))
(deffoo nnvirtual-request-update-mark (group article mark)
(let* ((nart (assq article nnvirtual-mapping))
(cgroup (cadr nart))
;; The component group might be a virtual group.
(nmark (gnus-request-update-mark cgroup (caddr nart) mark)))
(when (and nart
(= mark nmark)
(gnus-group-auto-expirable-p cgroup))
(setq mark gnus-expirable-mark)))
mark)
(deffoo nnvirtual-close-group (group &optional server)
(when (nnvirtual-possibly-change-server server)
;; Copy (un)read articles.
(nnvirtual-update-reads)
;; We copy the marks from this group to the component
;; groups here.
(nnvirtual-update-marked))
t)
(deffoo nnvirtual-request-list (&optional server)
(nnheader-report 'nnvirtual "LIST is not implemented."))
(deffoo nnvirtual-request-newgroups (date &optional server)
(nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
(deffoo nnvirtual-request-list-newsgroups (&optional server)
(nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
(deffoo nnvirtual-request-update-info (group info &optional server)
(when (nnvirtual-possibly-change-server server)
(let ((map nnvirtual-mapping)
(marks (mapcar (lambda (m) (list (cdr m))) gnus-article-mark-lists))
reads mr m op)
;; Go through the mapping.
(while map
(unless (nth 3 (setq m (pop map)))
;; Read article.
(push (car m) reads))
;; Copy marks.
(when (setq mr (nth 4 m))
(while mr
(setcdr (setq op (assq (pop mr) marks)) (cons (car m) (cdr op))))))
;; Compress the marks and the reads.
(setq mr marks)
(while mr
(setcdr (car mr) (gnus-compress-sequence (sort (cdr (pop mr)) '<))))
(setcar (cddr info) (gnus-compress-sequence (nreverse reads)))
;; Remove empty marks lists.
(while (and marks (not (cdar marks)))
(setq marks (cdr marks)))
(setq mr marks)
(while (cdr mr)
(if (cdadr mr)
(setq mr (cdr mr))
(setcdr mr (cddr mr))))
;; Enter these new marks into the info of the group.
(if (nthcdr 3 info)
(setcar (nthcdr 3 info) marks)
;; Add the marks lists to the end of the info.
(when marks
(setcdr (nthcdr 2 info) (list marks))))
t)))
(deffoo nnvirtual-catchup-group (group &optional server all)
(nnvirtual-possibly-change-server server)
(let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
(gnus-expert-user t))
;; Make sure all groups are activated.
(mapcar
(lambda (g)
(when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
(gnus-activate-group g)))
nnvirtual-component-groups)
(save-excursion
(set-buffer gnus-group-buffer)
(gnus-group-catchup-current nil all))))
(deffoo nnvirtual-find-group-art (group article)
"Return the real group and article for virtual GROUP and ARTICLE."
(let ((mart (assq article nnvirtual-mapping)))
(when mart
(cons (cadr mart) (caddr mart)))))
;;; Internal functions.
(defun nnvirtual-convert-headers ()
"Convert HEAD headers into NOV headers."
(save-excursion
(set-buffer nntp-server-buffer)
(let* ((dependencies (make-vector 100 0))
(headers (gnus-get-newsgroup-headers dependencies))
header)
(erase-buffer)
(while (setq header (pop headers))
(nnheader-insert-nov header)))))
(defun nnvirtual-possibly-change-server (server)
(or (not server)
(nnoo-current-server-p 'nnvirtual server)
(nnvirtual-open-server server)))
(defun nnvirtual-update-marked ()
"Copy marks from the virtual group to the component groups."
(let ((mark-lists gnus-article-mark-lists)
(marks (gnus-info-marks (gnus-get-info (nnvirtual-current-group))))
type list mart cgroups)
(while (setq type (cdr (pop mark-lists)))
(setq list (gnus-uncompress-range (cdr (assq type marks))))
(setq cgroups
(mapcar (lambda (g) (list g)) nnvirtual-component-groups))
(while list
(nconc (assoc (cadr (setq mart (assq (pop list) nnvirtual-mapping)))
cgroups)
(list (caddr mart))))
(while cgroups
(gnus-add-marked-articles
(caar cgroups) type (cdar cgroups) nil t)
(gnus-group-update-group (car (pop cgroups)) t)))))
(defun nnvirtual-update-reads ()
"Copy (un)reads from the current group to the component groups."
(let ((groups (mapcar (lambda (g) (list g)) nnvirtual-component-groups))
(articles (gnus-list-of-unread-articles
(nnvirtual-current-group)))
m)
(while articles
(setq m (assq (pop articles) nnvirtual-mapping))
(nconc (assoc (nth 1 m) groups) (list (nth 2 m))))
(while groups
(gnus-update-read-articles (caar groups) (cdr (pop groups))))))
(defun nnvirtual-current-group ()
"Return the prefixed name of the current nnvirtual group."
(concat "nnvirtual:" nnvirtual-current-group))
(defsubst nnvirtual-marks (article marks)
"Return a list of mark types for ARTICLE."
(let (out)
(while marks
(when (memq article (cdar marks))
(push (caar marks) out))
(setq marks (cdr marks)))
out))
(defun nnvirtual-create-mapping ()
"Create an article mapping for the current group."
(let* ((div nil)
m marks list article unreads marks active
(map (sort
(apply
'nconc
(mapcar
(lambda (g)
(when (and (setq active (gnus-activate-group g))
(> (cdr active) (car active)))
(setq unreads (gnus-list-of-unread-articles g)
marks (gnus-uncompress-marks
(gnus-info-marks (gnus-get-info g))))
(when gnus-use-cache
(push (cons 'cache (gnus-cache-articles-in-group g))
marks))
(setq div (/ (float (car active))
(if (zerop (cdr active))
1 (cdr active))))
(mapcar (lambda (n)
(list (* div (- n (car active)))
g n (and (memq n unreads) t)
(inline (nnvirtual-marks n marks))))
(gnus-uncompress-range active))))
nnvirtual-component-groups))
(lambda (m1 m2)
(< (car m1) (car m2)))))
(i 0))
(setq nnvirtual-mapping map)
;; Set the virtual article numbers.
(while (setq m (pop map))
(setcar m (setq article (incf i))))))
(provide 'nnvirtual)
;;; nnvirtual.el ends here

110
lisp/score-mode.el
View file

@ -1,110 +0,0 @@
;;; score-mode.el --- mode for editing Gnus score files
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news, mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(require 'easymenu)
(require 'timezone)
(eval-when-compile (require 'cl))
(defvar gnus-score-mode-hook nil
"*Hook run in score mode buffers.")
(defvar gnus-score-menu-hook nil
"*Hook run after creating the score mode menu.")
(defvar gnus-score-edit-exit-function nil
"Function run on exit from the score buffer.")
(defvar gnus-score-mode-map nil)
(unless gnus-score-mode-map
(setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
(define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-exit)
(define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)
(define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print))
;;;###autoload
(defun gnus-score-mode ()
"Mode for editing Gnus score files.
This mode is an extended emacs-lisp mode.
\\{gnus-score-mode-map}"
(interactive)
(kill-all-local-variables)
(use-local-map gnus-score-mode-map)
(when menu-bar-mode
(gnus-score-make-menu-bar))
(set-syntax-table emacs-lisp-mode-syntax-table)
(setq major-mode 'gnus-score-mode)
(setq mode-name "Score")
(lisp-mode-variables nil)
(make-local-variable 'gnus-score-edit-exit-function)
(run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
(defun gnus-score-make-menu-bar ()
(unless (boundp 'gnus-score-menu)
(easy-menu-define
gnus-score-menu gnus-score-mode-map ""
'("Score"
["Exit" gnus-score-edit-exit t]
["Insert date" gnus-score-edit-insert-date t]
["Format" gnus-score-pretty-print t]))
(run-hooks 'gnus-score-menu-hook)))
(defun gnus-score-edit-insert-date ()
"Insert date in numerical format."
(interactive)
(princ (gnus-score-day-number (current-time)) (current-buffer)))
(defun gnus-score-pretty-print ()
"Format the current score file."
(interactive)
(goto-char (point-min))
(let ((form (read (current-buffer))))
(erase-buffer)
(pp form (current-buffer)))
(goto-char (point-min)))
(defun gnus-score-edit-exit ()
"Stop editing the score file."
(interactive)
(unless (file-exists-p (file-name-directory (buffer-file-name)))
(make-directory (file-name-directory (buffer-file-name)) t))
(save-buffer)
(bury-buffer (current-buffer))
(let ((buf (current-buffer)))
(when gnus-score-edit-exit-function
(funcall gnus-score-edit-exit-function))
(when (eq buf (current-buffer))
(switch-to-buffer (other-buffer (current-buffer))))))
(defun gnus-score-day-number (time)
(let ((dat (decode-time time)))
(timezone-absolute-from-gregorian
(nth 4 dat) (nth 3 dat) (nth 5 dat))))
(provide 'score-mode)
;;; score-mode.el ends here

82
lisp/version.el Normal file
View file

@ -0,0 +1,82 @@
;;; version.el --- record version number of Emacs.
;;; Copyright (C) 1985, 1992, 1994, 1995, 1999 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
(defconst emacs-version "20.5.92" "\
Version numbers of this version of Emacs.")
(defconst emacs-major-version
(progn (string-match "^[0-9]+" emacs-version)
(string-to-int (match-string 0 emacs-version)))
"Major version number of this version of Emacs.
This variable first existed in version 19.23.")
(defconst emacs-minor-version
(progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
(string-to-int (match-string 1 emacs-version)))
"Minor version number of this version of Emacs.
This variable first existed in version 19.23.")
(defconst emacs-build-time (current-time) "\
Time at which Emacs was dumped out.")
(defconst emacs-build-system (system-name))
(defun emacs-version (&optional here) "\
Return string describing the version of Emacs that is running.
If optional argument HERE is non-nil, insert string at point.
Don't use this function in programs to choose actions according
to the system configuration; look at `system-configuration' instead."
(interactive "P")
(let ((version-string
(format (if (not (interactive-p))
"GNU Emacs %s (%s%s)\n of %s on %s"
"GNU Emacs %s (%s%s) of %s on %s")
emacs-version
system-configuration
(cond ((featurep 'motif) ", Motif")
((featurep 'x-toolkit) ", X toolkit")
(t ""))
(format-time-string "%a %b %e %Y" emacs-build-time)
emacs-build-system)))
(if here
(insert version-string)
(if (interactive-p)
(message "%s" version-string)
version-string))))
;;; We hope that this alias is easier for people to find.
(defalias 'version 'emacs-version)
;;; We put version info into the executable in the form that ident(1) uses.
(or (memq system-type '(vax-vms windows-nt ms-dos))
(purecopy (concat "\n$Id: " (subst-char-in-string ?\n ? (emacs-version))
" $\n")))
;;Local variables:
;;version-control: never
;;End:
;;; version.el ends here