--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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)
+ ;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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")))
+\f
+;;;### (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
--- /dev/null
+;;; 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
--- /dev/null
+;;; 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)))
+
+\f
+;;;
+;;; 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.
--- /dev/null
+;;; gnus-topic.el --- a folding minor mode for Gnus group buffers
+;; Copyright (C) 1995,96 Free Software Foundation, Inc.
+
+;; Author: Ilja Weis <kult@uni-paderborn.de>
+;; 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-topic-mode nil
+ "Minor mode for Gnus group buffers.")
+
+(defvar gnus-topic-mode-hook nil
+ "Hook run in topic mode buffers.")
+
+(defvar gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n"
+ "Format of topic lines.
+It works along the same lines as a normal formatting string,
+with some simple extensions.
+
+%i Indentation based on topic level.
+%n Topic name.
+%v Nothing if the topic is visible, \"...\" otherwise.
+%g Number of groups in the topic.
+%a Number of unread articles in the groups in the topic.
+%A Number of unread articles in the groups in the topic and its subtopics.
+")
+
+(defvar gnus-topic-indent-level 2
+ "*How much each subtopic should be indented.")
+
+;; Internal variables.
+
+(defvar gnus-topic-active-topology nil)
+(defvar gnus-topic-active-alist nil)
+
+(defvar gnus-topology-checked-p nil
+ "Whether the topology has been checked in this session.")
+
+(defvar gnus-topic-killed-topics nil)
+(defvar gnus-topic-inhibit-change-level nil)
+(defvar gnus-topic-tallied-groups nil)
+
+(defconst gnus-topic-line-format-alist
+ `((?n name ?s)
+ (?v visible ?s)
+ (?i indentation ?s)
+ (?g number-of-groups ?d)
+ (?a (gnus-topic-articles-in-topic entries) ?d)
+ (?A total-number-of-articles ?d)
+ (?l level ?d)))
+
+(defvar gnus-topic-line-format-spec nil)
+
+;; Functions.
+
+(defun gnus-group-topic-name ()
+ "The name of the topic on the current line."
+ (let ((topic (get-text-property (gnus-point-at-bol) 'gnus-topic)))
+ (and topic (symbol-name topic))))
+
+(defun gnus-group-topic-level ()
+ "The level of the topic on the current line."
+ (get-text-property (gnus-point-at-bol) 'gnus-topic-level))
+
+(defun gnus-group-topic-unread ()
+ "The number of unread articles in topic on the current line."
+ (get-text-property (gnus-point-at-bol) 'gnus-topic-unread))
+
+(defun gnus-topic-unread (topic)
+ "Return the number of unread articles in TOPIC."
+ (or (save-excursion
+ (and (gnus-topic-goto-topic topic)
+ (gnus-group-topic-unread)))
+ 0))
+
+(defun gnus-topic-init-alist ()
+ "Initialize the topic structures."
+ (setq gnus-topic-topology
+ (cons (list "Gnus" 'visible)
+ (mapcar (lambda (topic)
+ (list (list (car topic) 'visible)))
+ '(("misc")))))
+ (setq gnus-topic-alist
+ (list (cons "misc"
+ (mapcar (lambda (info) (gnus-info-group info))
+ (cdr gnus-newsrc-alist)))
+ (list "Gnus")))
+ (gnus-topic-enter-dribble))
+
+(defun gnus-group-prepare-topics (level &optional all lowest regexp list-topic topic-level)
+ "List all newsgroups with unread articles of level LEVEL or lower, and
+use the `gnus-group-topics' to sort the groups.
+If ALL is non-nil, list groups that have no unread articles.
+If LOWEST is non-nil, list all newsgroups of level LOWEST or higher."
+ (set-buffer gnus-group-buffer)
+ (let ((buffer-read-only nil)
+ (lowest (or lowest 1)))
+
+ (setq gnus-topic-tallied-groups nil)
+
+ (when (or (not gnus-topic-alist)
+ (not gnus-topology-checked-p))
+ (gnus-topic-check-topology))
+
+ (unless list-topic
+ (erase-buffer))
+
+ ;; List dead groups?
+ (when (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie))
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+ gnus-level-zombie ?Z
+ regexp))
+
+ (when (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-killed-list (sort gnus-killed-list 'string<))
+ gnus-level-killed ?K
+ regexp))
+
+ ;; Use topics.
+ (when (< lowest gnus-level-zombie)
+ (if list-topic
+ (let ((top (gnus-topic-find-topology list-topic)))
+ (gnus-topic-prepare-topic (cdr top) (car top)
+ (or topic-level level) all))
+ (gnus-topic-prepare-topic gnus-topic-topology 0
+ (or topic-level level) all))))
+
+ (gnus-group-set-mode-line)
+ (setq gnus-group-list-mode (cons level all))
+ (run-hooks 'gnus-group-prepare-hook))
+
+(defun gnus-topic-prepare-topic (topicl level &optional list-level all silent)
+ "Insert TOPIC into the group buffer.
+If SILENT, don't insert anything. Return the number of unread
+articles in the topic and its subtopics."
+ (let* ((type (pop topicl))
+ (entries (gnus-topic-find-groups (car type) list-level all))
+ (visiblep (and (eq (nth 1 type) 'visible) (not silent)))
+ (gnus-group-indentation
+ (make-string (* gnus-topic-indent-level level) ? ))
+ (beg (progn (beginning-of-line) (point)))
+ (topicl (reverse topicl))
+ (all-entries entries)
+ (unread 0)
+ (topic (car type))
+ info entry end active)
+ ;; Insert any sub-topics.
+ (while topicl
+ (incf unread
+ (gnus-topic-prepare-topic
+ (pop topicl) (1+ level) list-level all
+ (not visiblep))))
+ (setq end (point))
+ (goto-char beg)
+ ;; Insert all the groups that belong in this topic.
+ (while (setq entry (pop entries))
+ (when visiblep
+ (if (stringp entry)
+ ;; Dead groups.
+ (gnus-group-insert-group-line
+ entry (if (member entry gnus-zombie-list) 8 9)
+ nil (- (1+ (cdr (setq active (gnus-active entry))))
+ (car active)) nil)
+ ;; Living groups.
+ (when (setq info (nth 2 entry))
+ (gnus-group-insert-group-line
+ (gnus-info-group info)
+ (gnus-info-level info) (gnus-info-marks info)
+ (car entry) (gnus-info-method info)))))
+ (when (and (listp entry)
+ (numberp (car entry))
+ (not (member (gnus-info-group (setq info (nth 2 entry)))
+ gnus-topic-tallied-groups)))
+ (push (gnus-info-group info) gnus-topic-tallied-groups)
+ (incf unread (car entry))))
+ (goto-char beg)
+ ;; Insert the topic line.
+ (unless silent
+ (gnus-extent-start-open (point))
+ (gnus-topic-insert-topic-line
+ (car type) visiblep
+ (not (eq (nth 2 type) 'hidden))
+ level all-entries unread))
+ (goto-char end)
+ unread))
+
+(defun gnus-topic-find-groups (topic &optional level all)
+ "Return entries for all visible groups in TOPIC."
+ (let ((groups (cdr (assoc topic gnus-topic-alist)))
+ info clevel unread group lowest params visible-groups entry active)
+ (setq lowest (or lowest 1))
+ (setq level (or level 7))
+ ;; We go through the newsrc to look for matches.
+ (while groups
+ (setq entry (gnus-gethash (setq group (pop groups)) gnus-newsrc-hashtb)
+ info (nth 2 entry)
+ params (gnus-info-params info)
+ active (gnus-active group)
+ unread (or (car entry)
+ (and (not (equal group "dummy.group"))
+ active
+ (- (1+ (cdr active)) (car active))))
+ clevel (or (gnus-info-level info)
+ (if (member group gnus-zombie-list) 8 9)))
+ (and
+ unread ; nil means that the group is dead.
+ (<= clevel level)
+ (>= clevel lowest) ; Is inside the level we want.
+ (or all
+ (if (eq unread t)
+ gnus-group-list-inactive-groups
+ (> unread 0))
+ (and gnus-list-groups-with-ticked-articles
+ (cdr (assq 'tick (gnus-info-marks info))))
+ ; Has right readedness.
+ ;; Check for permanent visibility.
+ (and gnus-permanently-visible-groups
+ (string-match gnus-permanently-visible-groups group))
+ (memq 'visible params)
+ (cdr (assq 'visible params)))
+ ;; Add this group to the list of visible groups.
+ (push (or entry group) visible-groups)))
+ (nreverse visible-groups)))
+
+(defun gnus-topic-remove-topic (&optional insert total-remove hide in-level)
+ "Remove the current topic."
+ (let ((topic (gnus-group-topic-name))
+ (level (gnus-group-topic-level))
+ (beg (progn (beginning-of-line) (point)))
+ buffer-read-only)
+ (when topic
+ (while (and (zerop (forward-line 1))
+ (> (or (gnus-group-topic-level) (1+ level)) level)))
+ (delete-region beg (point))
+ (setcar (cdadr (gnus-topic-find-topology topic))
+ (if insert 'visible 'invisible))
+ (when hide
+ (setcdr (cdadr (gnus-topic-find-topology topic))
+ (list hide)))
+ (unless total-remove
+ (gnus-topic-insert-topic topic in-level)))))
+
+(defun gnus-topic-insert-topic (topic &optional level)
+ "Insert TOPIC."
+ (gnus-group-prepare-topics
+ (car gnus-group-list-mode) (cdr gnus-group-list-mode)
+ nil nil topic level))
+
+(defun gnus-topic-fold (&optional insert)
+ "Remove/insert the current topic."
+ (let ((topic (gnus-group-topic-name)))
+ (when topic
+ (save-excursion
+ (if (not (gnus-group-active-topic-p))
+ (gnus-topic-remove-topic
+ (or insert (not (gnus-topic-visible-p))))
+ (let ((gnus-topic-topology gnus-topic-active-topology)
+ (gnus-topic-alist gnus-topic-active-alist)
+ (gnus-group-list-mode (cons 5 t)))
+ (gnus-topic-remove-topic
+ (or insert (not (gnus-topic-visible-p))) nil nil 9)))))))
+
+(defun gnus-group-topic-p ()
+ "Return non-nil if the current line is a topic."
+ (gnus-group-topic-name))
+
+(defun gnus-topic-visible-p ()
+ "Return non-nil if the current topic is visible."
+ (get-text-property (gnus-point-at-bol) 'gnus-topic-visible))
+
+(defun gnus-topic-insert-topic-line (name visiblep shownp level entries
+ &optional unread)
+ (let* ((visible (if visiblep "" "..."))
+ (indentation (make-string (* gnus-topic-indent-level level) ? ))
+ (total-number-of-articles unread)
+ (number-of-groups (length entries))
+ (active-topic (eq gnus-topic-alist gnus-topic-active-alist)))
+ (beginning-of-line)
+ ;; Insert the text.
+ (gnus-add-text-properties
+ (point)
+ (prog1 (1+ (point))
+ (eval gnus-topic-line-format-spec)
+ (gnus-topic-remove-excess-properties)1)
+ (list 'gnus-topic (intern name)
+ 'gnus-topic-level level
+ 'gnus-topic-unread unread
+ 'gnus-active active-topic
+ 'gnus-topic-visible visiblep))))
+
+(defun gnus-topic-previous-topic (topic)
+ "Return the previous topic on the same level as TOPIC."
+ (let ((top (cddr (gnus-topic-find-topology
+ (gnus-topic-parent-topic topic)))))
+ (unless (equal topic (caaar top))
+ (while (and top (not (equal (caaadr top) topic)))
+ (setq top (cdr top)))
+ (caaar top))))
+
+(defun gnus-topic-parent-topic (topic &optional topology)
+ "Return the parent of TOPIC."
+ (unless topology
+ (setq topology gnus-topic-topology))
+ (let ((parent (car (pop topology)))
+ result found)
+ (while (and topology
+ (not (setq found (equal (caaar topology) topic)))
+ (not (setq result (gnus-topic-parent-topic topic
+ (car topology)))))
+ (setq topology (cdr topology)))
+ (or result (and found parent))))
+
+(defun gnus-topic-next-topic (topic &optional previous)
+ "Return the next sibling of TOPIC."
+ (let ((topology gnus-topic-topology)
+ (parentt (cddr (gnus-topic-find-topology
+ (gnus-topic-parent-topic topic))))
+ prev)
+ (while (and parentt
+ (not (equal (caaar parentt) topic)))
+ (setq prev (caaar parentt)
+ parentt (cdr parentt)))
+ (if previous
+ prev
+ (caaadr parentt))))
+
+(defun gnus-topic-find-topology (topic &optional topology level remove)
+ "Return the topology of TOPIC."
+ (unless topology
+ (setq topology gnus-topic-topology)
+ (setq level 0))
+ (let ((top topology)
+ result)
+ (if (equal (caar topology) topic)
+ (progn
+ (when remove
+ (delq topology remove))
+ (cons level topology))
+ (setq topology (cdr topology))
+ (while (and topology
+ (not (setq result (gnus-topic-find-topology
+ topic (car topology) (1+ level)
+ (and remove top)))))
+ (setq topology (cdr topology)))
+ result)))
+
+(gnus-add-shutdown 'gnus-topic-close 'gnus)
+
+(defun gnus-topic-close ()
+ (setq gnus-topic-active-topology nil
+ gnus-topic-active-alist nil
+ gnus-topic-killed-topics nil
+ gnus-topic-tallied-groups nil
+ gnus-topology-checked-p nil))
+
+(defun gnus-topic-check-topology ()
+ ;; The first time we set the topology to whatever we have
+ ;; gotten here, which can be rather random.
+ (unless gnus-topic-alist
+ (gnus-topic-init-alist))
+
+ (setq gnus-topology-checked-p t)
+ (let ((topics (gnus-topic-list))
+ (alist gnus-topic-alist)
+ changed)
+ (while alist
+ (unless (member (caar alist) topics)
+ (nconc gnus-topic-topology
+ (list (list (list (caar alist) 'visible))))
+ (setq changed t))
+ (setq alist (cdr alist)))
+ (when changed
+ (gnus-topic-enter-dribble)))
+ (let* ((tgroups (apply 'append (mapcar (lambda (entry) (cdr entry))
+ gnus-topic-alist)))
+ (entry (assoc (caar gnus-topic-topology) gnus-topic-alist))
+ (newsrc gnus-newsrc-alist)
+ group)
+ (while newsrc
+ (unless (member (setq group (gnus-info-group (pop newsrc))) tgroups)
+ (setcdr entry (cons group (cdr entry)))))))
+
+(defvar gnus-tmp-topics nil)
+(defun gnus-topic-list (&optional topology)
+ (unless topology
+ (setq topology gnus-topic-topology
+ gnus-tmp-topics nil))
+ (push (caar topology) gnus-tmp-topics)
+ (mapcar 'gnus-topic-list (cdr topology))
+ gnus-tmp-topics)
+
+(defun gnus-topic-enter-dribble ()
+ (gnus-dribble-enter
+ (format "(setq gnus-topic-topology '%S)" gnus-topic-topology)))
+
+(defun gnus-topic-articles-in-topic (entries)
+ (let ((total 0)
+ number)
+ (while entries
+ (when (numberp (setq number (car (pop entries))))
+ (incf total number)))
+ total))
+
+(defun gnus-group-topic (group)
+ "Return the topic GROUP is a member of."
+ (let ((alist gnus-topic-alist)
+ out)
+ (while alist
+ (when (member group (cdar alist))
+ (setq out (caar alist)
+ alist nil))
+ (setq alist (cdr alist)))
+ out))
+
+(defun gnus-topic-goto-topic (topic)
+ "Go to TOPIC."
+ (when topic
+ (gnus-goto-char (text-property-any (point-min) (point-max)
+ 'gnus-topic (intern topic)))))
+
+(defun gnus-group-parent-topic ()
+ "Return the name of the current topic."
+ (let ((result
+ (or (get-text-property (point) 'gnus-topic)
+ (save-excursion
+ (and (gnus-goto-char (previous-single-property-change
+ (point) 'gnus-topic))
+ (get-text-property (max (1- (point)) (point-min))
+ 'gnus-topic))))))
+ (when result
+ (symbol-name result))))
+
+(defun gnus-topic-update-topic ()
+ "Update all parent topics to the current group."
+ (when (and (eq major-mode 'gnus-group-mode)
+ gnus-topic-mode)
+ (let ((group (gnus-group-group-name))
+ (buffer-read-only nil))
+ (when (and group (gnus-get-info group)
+ (gnus-topic-goto-topic (gnus-group-parent-topic)))
+ (gnus-topic-update-topic-line (gnus-group-topic-name))
+ (gnus-group-goto-group group)
+ (gnus-group-position-point)))))
+
+(defun gnus-topic-goto-missing-group (group)
+ "Place point where GROUP is supposed to be inserted."
+ (let* ((topic (gnus-group-topic group))
+ (groups (cdr (assoc topic gnus-topic-alist)))
+ (g (cdr (member group groups)))
+ (unfound t))
+ (while (and g unfound)
+ (when (gnus-group-goto-group (pop g))
+ (beginning-of-line)
+ (setq unfound nil)))
+ (when unfound
+ (setq g (cdr (member group (reverse groups))))
+ (while (and g unfound)
+ (when (gnus-group-goto-group (pop g))
+ (forward-line 1)
+ (setq unfound nil)))
+ (when unfound
+ (gnus-topic-goto-topic topic)
+ (forward-line 1)))))
+
+(defun gnus-topic-update-topic-line (topic-name &optional reads)
+ (let* ((top (gnus-topic-find-topology topic-name))
+ (type (cadr top))
+ (children (cddr top))
+ (entries (gnus-topic-find-groups
+ (car type) (car gnus-group-list-mode)
+ (cdr gnus-group-list-mode)))
+ (parent (gnus-topic-parent-topic topic-name))
+ (all-entries entries)
+ (unread 0)
+ old-unread entry)
+ (when (gnus-topic-goto-topic (car type))
+ ;; Tally all the groups that belong in this topic.
+ (if reads
+ (setq unread (- (gnus-group-topic-unread) reads))
+ (while children
+ (incf unread (gnus-topic-unread (caar (pop children)))))
+ (while (setq entry (pop entries))
+ (when (numberp (car entry))
+ (incf unread (car entry)))))
+ (setq old-unread (gnus-group-topic-unread))
+ ;; Insert the topic line.
+ (gnus-topic-insert-topic-line
+ (car type) (gnus-topic-visible-p)
+ (not (eq (nth 2 type) 'hidden))
+ (gnus-group-topic-level) all-entries unread)
+ (gnus-delete-line))
+ (when parent
+ (forward-line -1)
+ (gnus-topic-update-topic-line
+ parent (- old-unread (gnus-group-topic-unread))))
+ unread))
+
+(defun gnus-topic-grok-active (&optional force)
+ "Parse all active groups and create topic structures for them."
+ ;; First we make sure that we have really read the active file.
+ (when (or force
+ (not gnus-topic-active-alist))
+ (let (groups)
+ ;; Get a list of all groups available.
+ (mapatoms (lambda (g) (when (symbol-value g)
+ (push (symbol-name g) groups)))
+ gnus-active-hashtb)
+ (setq groups (sort groups 'string<))
+ ;; Init the variables.
+ (setq gnus-topic-active-topology (list (list "" 'visible)))
+ (setq gnus-topic-active-alist nil)
+ ;; Descend the top-level hierarchy.
+ (gnus-topic-grok-active-1 gnus-topic-active-topology groups)
+ ;; Set the top-level topic names to something nice.
+ (setcar (car gnus-topic-active-topology) "Gnus active")
+ (setcar (car gnus-topic-active-alist) "Gnus active"))))
+
+(defun gnus-topic-grok-active-1 (topology groups)
+ (let* ((name (caar topology))
+ (prefix (concat "^" (regexp-quote name)))
+ tgroups ntopology group)
+ (while (and groups
+ (string-match prefix (setq group (car groups))))
+ (if (not (string-match "\\." group (match-end 0)))
+ ;; There are no further hierarchies here, so we just
+ ;; enter this group into the list belonging to this
+ ;; topic.
+ (push (pop groups) tgroups)
+ ;; New sub-hierarchy, so we add it to the topology.
+ (nconc topology (list (setq ntopology
+ (list (list (substring
+ group 0 (match-end 0))
+ 'invisible)))))
+ ;; Descend the hierarchy.
+ (setq groups (gnus-topic-grok-active-1 ntopology groups))))
+ ;; We remove the trailing "." from the topic name.
+ (setq name
+ (if (string-match "\\.$" name)
+ (substring name 0 (match-beginning 0))
+ name))
+ ;; Add this topic and its groups to the topic alist.
+ (push (cons name (nreverse tgroups)) gnus-topic-active-alist)
+ (setcar (car topology) name)
+ ;; We return the rest of the groups that didn't belong
+ ;; to this topic.
+ groups))
+
+(defun gnus-group-active-topic-p ()
+ "Return whether the current active comes from the active topics."
+ (save-excursion
+ (beginning-of-line)
+ (get-text-property (point) 'gnus-active)))
+
+;;; Topic mode, commands and keymap.
+
+(defvar gnus-topic-mode-map nil)
+(defvar gnus-group-topic-map nil)
+
+(unless gnus-topic-mode-map
+ (setq gnus-topic-mode-map (make-sparse-keymap))
+
+ ;; Override certain group mode keys.
+ (gnus-define-keys
+ gnus-topic-mode-map
+ "=" gnus-topic-select-group
+ "\r" gnus-topic-select-group
+ " " gnus-topic-read-group
+ "\C-k" gnus-topic-kill-group
+ "\C-y" gnus-topic-yank-group
+ "\M-g" gnus-topic-get-new-news-this-topic
+ "AT" gnus-topic-list-active
+ gnus-mouse-2 gnus-mouse-pick-topic)
+
+ ;; Define a new submap.
+ (gnus-define-keys
+ (gnus-group-topic-map "T" gnus-group-mode-map)
+ "#" gnus-topic-mark-topic
+ "\M-#" gnus-topic-unmark-topic
+ "n" gnus-topic-create-topic
+ "m" gnus-topic-move-group
+ "D" gnus-topic-remove-group
+ "c" gnus-topic-copy-group
+ "h" gnus-topic-hide-topic
+ "s" gnus-topic-show-topic
+ "M" gnus-topic-move-matching
+ "C" gnus-topic-copy-matching
+ "\C-i" gnus-topic-indent
+ [tab] gnus-topic-indent
+ "r" gnus-topic-rename
+ "\177" gnus-topic-delete))
+
+(defun gnus-topic-make-menu-bar ()
+ (unless (boundp 'gnus-topic-menu)
+ (easy-menu-define
+ gnus-topic-menu gnus-topic-mode-map ""
+ '("Topics"
+ ["Toggle topics" gnus-topic-mode t]
+ ("Groups"
+ ["Copy" gnus-topic-copy-group t]
+ ["Move" gnus-topic-move-group t]
+ ["Remove" gnus-topic-remove-group t]
+ ["Copy matching" gnus-topic-copy-matching t]
+ ["Move matching" gnus-topic-move-matching t])
+ ("Topics"
+ ["Show" gnus-topic-show-topic t]
+ ["Hide" gnus-topic-hide-topic t]
+ ["Delete" gnus-topic-delete t]
+ ["Rename" gnus-topic-rename t]
+ ["Create" gnus-topic-create-topic t]
+ ["Mark" gnus-topic-mark-topic t]
+ ["Indent" gnus-topic-indent t])
+ ["List active" gnus-topic-list-active t]))))
+
+(defun gnus-topic-mode (&optional arg redisplay)
+ "Minor mode for topicsifying Gnus group buffers."
+ (interactive (list current-prefix-arg t))
+ (when (eq major-mode 'gnus-group-mode)
+ (make-local-variable 'gnus-topic-mode)
+ (setq gnus-topic-mode
+ (if (null arg) (not gnus-topic-mode)
+ (> (prefix-numeric-value arg) 0)))
+ ;; Infest Gnus with topics.
+ (when gnus-topic-mode
+ (when (and menu-bar-mode
+ (gnus-visual-p 'topic-menu 'menu))
+ (gnus-topic-make-menu-bar))
+ (setq gnus-topic-line-format-spec
+ (gnus-parse-format gnus-topic-line-format
+ gnus-topic-line-format-alist t))
+ (unless (assq 'gnus-topic-mode minor-mode-alist)
+ (push '(gnus-topic-mode " Topic") minor-mode-alist))
+ (unless (assq 'gnus-topic-mode minor-mode-map-alist)
+ (push (cons 'gnus-topic-mode gnus-topic-mode-map)
+ minor-mode-map-alist))
+ (add-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
+ (add-hook 'gnus-group-catchup-group-hook 'gnus-topic-update-topic)
+ (add-hook 'gnus-group-update-group-hook 'gnus-topic-update-topic)
+ (make-local-variable 'gnus-group-prepare-function)
+ (setq gnus-group-prepare-function 'gnus-group-prepare-topics)
+ (make-local-variable 'gnus-group-goto-next-group-function)
+ (setq gnus-group-goto-next-group-function
+ 'gnus-topic-goto-next-group)
+ (setq gnus-group-change-level-function 'gnus-topic-change-level)
+ (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group)
+ (make-local-variable 'gnus-group-indentation-function)
+ (setq gnus-group-indentation-function
+ 'gnus-topic-group-indentation)
+ (setq gnus-topology-checked-p nil)
+ ;; We check the topology.
+ (when gnus-newsrc-alist
+ (gnus-topic-check-topology))
+ (run-hooks 'gnus-topic-mode-hook))
+ ;; Remove topic infestation.
+ (unless gnus-topic-mode
+ (remove-hook 'gnus-summary-exit-hook 'gnus-topic-update-topic)
+ (remove-hook 'gnus-group-change-level-function
+ 'gnus-topic-change-level)
+ (setq gnus-group-prepare-function 'gnus-group-prepare-flat))
+ (when redisplay
+ (gnus-group-list-groups))))
+
+(defun gnus-topic-select-group (&optional all)
+ "Select this newsgroup.
+No article is selected automatically.
+If ALL is non-nil, already read articles become readable.
+If ALL is a number, fetch this number of articles."
+ (interactive "P")
+ (if (gnus-group-topic-p)
+ (let ((gnus-group-list-mode
+ (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
+ (gnus-topic-fold all))
+ (gnus-group-select-group all)))
+
+(defun gnus-mouse-pick-topic (e)
+ "Select the group or topic under the mouse pointer."
+ (interactive "e")
+ (mouse-set-point e)
+ (gnus-topic-read-group nil))
+
+(defun gnus-topic-read-group (&optional all no-article group)
+ "Read news in this newsgroup.
+If the prefix argument ALL is non-nil, already read articles become
+readable. IF ALL is a number, fetch this number of articles. If the
+optional argument NO-ARTICLE is non-nil, no article will be
+auto-selected upon group entry. If GROUP is non-nil, fetch that
+group."
+ (interactive "P")
+ (if (gnus-group-topic-p)
+ (let ((gnus-group-list-mode
+ (if all (cons (if (numberp all) all 7) t) gnus-group-list-mode)))
+ (gnus-topic-fold all))
+ (gnus-group-read-group all no-article group)))
+
+(defun gnus-topic-create-topic (topic parent &optional previous full-topic)
+ (interactive
+ (list
+ (read-string "New topic: ")
+ (gnus-group-parent-topic)))
+ ;; Check whether this topic already exists.
+ (when (gnus-topic-find-topology topic)
+ (error "Topic aleady exists"))
+ (unless parent
+ (setq parent (caar gnus-topic-topology)))
+ (let ((top (cdr (gnus-topic-find-topology parent)))
+ (full-topic (or full-topic `((,topic visible)))))
+ (unless top
+ (error "No such parent topic: %s" parent))
+ (if previous
+ (progn
+ (while (and (cdr top)
+ (not (equal (caaadr top) previous)))
+ (setq top (cdr top)))
+ (setcdr top (cons full-topic (cdr top))))
+ (nconc top (list full-topic)))
+ (unless (assoc topic gnus-topic-alist)
+ (push (list topic) gnus-topic-alist)))
+ (gnus-topic-enter-dribble)
+ (gnus-group-list-groups)
+ (gnus-topic-goto-topic topic))
+
+(defun gnus-topic-move-group (n topic &optional copyp)
+ "Move the next N groups to TOPIC.
+If COPYP, copy the groups instead."
+ (interactive
+ (list current-prefix-arg
+ (completing-read "Move to topic: " gnus-topic-alist nil t)))
+ (let ((groups (gnus-group-process-prefix n))
+ (topicl (assoc topic gnus-topic-alist))
+ entry)
+ (mapcar (lambda (g)
+ (gnus-group-remove-mark g)
+ (when (and
+ (setq entry (assoc (gnus-group-parent-topic)
+ gnus-topic-alist))
+ (not copyp))
+ (setcdr entry (gnus-delete-first g (cdr entry))))
+ (nconc topicl (list g)))
+ groups)
+ (gnus-group-position-point))
+ (gnus-topic-enter-dribble)
+ (gnus-group-list-groups))
+
+(defun gnus-topic-remove-group ()
+ "Remove the current group from the topic."
+ (interactive)
+ (let ((topicl (assoc (gnus-group-parent-topic) gnus-topic-alist))
+ (group (gnus-group-group-name))
+ (buffer-read-only nil))
+ (when (and topicl group)
+ (gnus-delete-line)
+ (gnus-delete-first group topicl))
+ (gnus-group-position-point)))
+
+(defun gnus-topic-copy-group (n topic)
+ "Copy the current group to a topic."
+ (interactive
+ (list current-prefix-arg
+ (completing-read "Copy to topic: " gnus-topic-alist nil t)))
+ (gnus-topic-move-group n topic t))
+
+(defun gnus-topic-group-indentation ()
+ (make-string
+ (* gnus-topic-indent-level
+ (or (save-excursion
+ (gnus-topic-goto-topic (gnus-group-parent-topic))
+ (gnus-group-topic-level)) 0)) ? ))
+
+(defun gnus-topic-change-level (group level oldlevel)
+ "Run when changing levels to enter/remove groups from topics."
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (when (and gnus-topic-mode
+ gnus-topic-alist
+ (not gnus-topic-inhibit-change-level))
+ ;; Remove the group from the topics.
+ (when (and (< oldlevel gnus-level-zombie)
+ (>= level gnus-level-zombie))
+ (let (alist)
+ (forward-line -1)
+ (when (setq alist (assoc (gnus-group-parent-topic) gnus-topic-alist))
+ (setcdr alist (gnus-delete-first group (cdr alist))))))
+ ;; If the group is subscribed. then we enter it into the topics.
+ (when (and (< level gnus-level-zombie)
+ (>= oldlevel gnus-level-zombie))
+ (let* ((prev (gnus-group-group-name))
+ (gnus-topic-inhibit-change-level t)
+ (gnus-group-indentation
+ (make-string
+ (* gnus-topic-indent-level
+ (or (save-excursion
+ (gnus-topic-goto-topic (gnus-group-parent-topic))
+ (gnus-group-topic-level)) 0)) ? ))
+ (yanked (list group))
+ alist talist end)
+ ;; Then we enter the yanked groups into the topics they belong
+ ;; to.
+ (when (setq alist (assoc (save-excursion
+ (forward-line -1)
+ (or
+ (gnus-group-parent-topic)
+ (caar gnus-topic-topology)))
+ gnus-topic-alist))
+ (setq talist alist)
+ (when (stringp yanked)
+ (setq yanked (list yanked)))
+ (if (not prev)
+ (nconc alist yanked)
+ (if (not (cdr alist))
+ (setcdr alist (nconc yanked (cdr alist)))
+ (while (and (not end) (cdr alist))
+ (when (equal (cadr alist) prev)
+ (setcdr alist (nconc yanked (cdr alist)))
+ (setq end t))
+ (setq alist (cdr alist)))
+ (unless end
+ (nconc talist yanked))))))
+ (gnus-topic-update-topic)))))
+
+(defun gnus-topic-goto-next-group (group props)
+ "Go to group or the next group after group."
+ (if (null group)
+ (gnus-topic-goto-topic (symbol-name (cadr (memq 'gnus-topic props))))
+ (if (gnus-group-goto-group group)
+ t
+ ;; The group is no longer visible.
+ (let* ((list (assoc (gnus-group-parent-topic) gnus-topic-alist))
+ (after (cdr (member group (cdr list)))))
+ ;; First try to put point on a group after the current one.
+ (while (and after
+ (not (gnus-group-goto-group (car after))))
+ (setq after (cdr after)))
+ ;; Then try to put point on a group before point.
+ (unless after
+ (setq after (cdr (member group (reverse (cdr list)))))
+ (while (and after
+ (not (gnus-group-goto-group (car after))))
+ (setq after (cdr after))))
+ ;; Finally, just put point on the topic.
+ (unless after
+ (gnus-topic-goto-topic (car list))
+ (setq after nil))
+ t))))
+
+(defun gnus-topic-kill-group (&optional n discard)
+ "Kill the next N groups."
+ (interactive "P")
+ (if (gnus-group-topic-p)
+ (let ((topic (gnus-group-topic-name)))
+ (gnus-topic-remove-topic nil t)
+ (push (gnus-topic-find-topology topic nil nil gnus-topic-topology)
+ gnus-topic-killed-topics))
+ (gnus-group-kill-group n discard)
+ (gnus-topic-update-topic)))
+
+(defun gnus-topic-yank-group (&optional arg)
+ "Yank the last topic."
+ (interactive "p")
+ (if gnus-topic-killed-topics
+ (let ((previous
+ (or (gnus-group-topic-name)
+ (gnus-topic-next-topic (gnus-group-parent-topic))))
+ (item (cdr (pop gnus-topic-killed-topics))))
+ (gnus-topic-create-topic
+ (caar item) (gnus-topic-parent-topic previous) previous
+ item)
+ (gnus-topic-goto-topic (caar item)))
+ (let* ((prev (gnus-group-group-name))
+ (gnus-topic-inhibit-change-level t)
+ (gnus-group-indentation
+ (make-string
+ (* gnus-topic-indent-level
+ (or (save-excursion
+ (gnus-topic-goto-topic (gnus-group-parent-topic))
+ (gnus-group-topic-level)) 0)) ? ))
+ yanked alist)
+ ;; We first yank the groups the normal way...
+ (setq yanked (gnus-group-yank-group arg))
+ ;; Then we enter the yanked groups into the topics they belong
+ ;; to.
+ (setq alist (assoc (save-excursion
+ (forward-line -1)
+ (gnus-group-parent-topic))
+ gnus-topic-alist))
+ (when (stringp yanked)
+ (setq yanked (list yanked)))
+ (if (not prev)
+ (nconc alist yanked)
+ (if (not (cdr alist))
+ (setcdr alist (nconc yanked (cdr alist)))
+ (while (cdr alist)
+ (when (equal (cadr alist) prev)
+ (setcdr alist (nconc yanked (cdr alist)))
+ (setq alist nil))
+ (setq alist (cdr alist))))))
+ (gnus-topic-update-topic)))
+
+(defun gnus-topic-hide-topic ()
+ "Hide all subtopics under the current topic."
+ (interactive)
+ (when (gnus-group-parent-topic)
+ (gnus-topic-goto-topic (gnus-group-parent-topic))
+ (gnus-topic-remove-topic nil nil 'hidden)))
+
+(defun gnus-topic-show-topic ()
+ "Show the hidden topic."
+ (interactive)
+ (when (gnus-group-topic-p)
+ (gnus-topic-remove-topic t nil 'shown)))
+
+(defun gnus-topic-mark-topic (topic &optional unmark)
+ "Mark all groups in the topic with the process mark."
+ (interactive (list (gnus-group-parent-topic)))
+ (save-excursion
+ (let ((groups (gnus-topic-find-groups topic 9 t)))
+ (while groups
+ (funcall (if unmark 'gnus-group-remove-mark 'gnus-group-set-mark)
+ (gnus-info-group (nth 2 (pop groups))))))))
+
+(defun gnus-topic-unmark-topic (topic &optional unmark)
+ "Remove the process mark from all groups in the topic."
+ (interactive (list (gnus-group-parent-topic)))
+ (gnus-topic-mark-topic topic t))
+
+(defun gnus-topic-get-new-news-this-topic (&optional n)
+ "Check for new news in the current topic."
+ (interactive "P")
+ (if (not (gnus-group-topic-p))
+ (gnus-group-get-new-news-this-group n)
+ (gnus-topic-mark-topic (gnus-group-topic-name))
+ (gnus-group-get-new-news-this-group)))
+
+(defun gnus-topic-move-matching (regexp topic &optional copyp)
+ "Move all groups that match REGEXP to some topic."
+ (interactive
+ (let (topic)
+ (nreverse
+ (list
+ (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t))
+ (read-string (format "Move to %s (regexp): " topic))))))
+ (gnus-group-mark-regexp regexp)
+ (gnus-topic-move-group nil topic copyp))
+
+(defun gnus-topic-copy-matching (regexp topic &optional copyp)
+ "Copy all groups that match REGEXP to some topic."
+ (interactive
+ (let (topic)
+ (nreverse
+ (list
+ (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t))
+ (read-string (format "Copy to %s (regexp): " topic))))))
+ (gnus-topic-move-matching regexp topic t))
+
+(defun gnus-topic-delete (topic)
+ "Delete a topic."
+ (interactive (list (gnus-group-topic-name)))
+ (unless topic
+ (error "No topic to be deleted"))
+ (let ((entry (assoc topic gnus-topic-alist))
+ (buffer-read-only nil))
+ (when (cdr entry)
+ (error "Topic not empty"))
+ ;; Delete if visible.
+ (when (gnus-topic-goto-topic topic)
+ (gnus-delete-line))
+ ;; Remove from alist.
+ (setq gnus-topic-alist (delq entry gnus-topic-alist))
+ ;; Remove from topology.
+ (gnus-topic-find-topology topic nil nil 'delete)))
+
+(defun gnus-topic-rename (old-name new-name)
+ "Rename a topic."
+ (interactive
+ (let ((topic (gnus-group-parent-topic)))
+ (list topic
+ (read-string (format "Rename %s to: " topic)))))
+ (let ((top (gnus-topic-find-topology old-name))
+ (entry (assoc old-name gnus-topic-alist)))
+ (when top
+ (setcar (cadr top) new-name))
+ (when entry
+ (setcar entry new-name))
+ (gnus-group-list-groups)))
+
+(defun gnus-topic-indent (&optional unindent)
+ "Indent a topic -- make it a sub-topic of the previous topic.
+If UNINDENT, remove an indentation."
+ (interactive "P")
+ (if unindent
+ (gnus-topic-unindent)
+ (let* ((topic (gnus-group-parent-topic))
+ (parent (gnus-topic-previous-topic topic)))
+ (unless parent
+ (error "Nothing to indent %s into" topic))
+ (when topic
+ (gnus-topic-goto-topic topic)
+ (gnus-topic-kill-group)
+ (gnus-topic-create-topic
+ topic parent nil (cdr (pop gnus-topic-killed-topics)))
+ (or (gnus-topic-goto-topic topic)
+ (gnus-topic-goto-topic parent))))))
+
+(defun gnus-topic-unindent ()
+ "Unindent a topic."
+ (interactive)
+ (let* ((topic (gnus-group-parent-topic))
+ (parent (gnus-topic-parent-topic topic))
+ (grandparent (gnus-topic-parent-topic parent)))
+ (unless grandparent
+ (error "Nothing to indent %s into" topic))
+ (when topic
+ (gnus-topic-goto-topic topic)
+ (gnus-topic-kill-group)
+ (gnus-topic-create-topic
+ topic grandparent (gnus-topic-next-topic parent)
+ (cdr (pop gnus-topic-killed-topics)))
+ (gnus-topic-goto-topic topic))))
+
+(defun gnus-topic-list-active (&optional force)
+ "List all groups that Gnus knows about in a topicsified fashion.
+If FORCE, always re-read the active file."
+ (interactive "P")
+ (when force
+ (gnus-get-killed-groups))
+ (gnus-topic-grok-active force)
+ (let ((gnus-topic-topology gnus-topic-active-topology)
+ (gnus-topic-alist gnus-topic-active-alist)
+ gnus-killed-list gnus-zombie-list)
+ (gnus-group-list-groups 9 nil 1)))
+
+(provide 'gnus-topic)
+
+;;; gnus-topic.el ends here
--- /dev/null
+;;; mail-header.el --- Mail header parsing, merging, formatting
+
+;; Copyright (C) 1996 by Free Software Foundation, Inc.
+
+;; Author: Erik Naggum <erik@arcana.naggum.no>
+;; Keywords: tools, mail, 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:
+
+;; This package provides an abstraction to RFC822-style messages, used in
+;; mail news, and some other systems. The simple syntactic rules for such
+;; headers, such as quoting and line folding, are routinely reimplemented
+;; in many individual packages. This package removes the need for this
+;; redundancy by representing message headers as association lists,
+;; offering functions to extract the set of headers from a message, to
+;; parse individual headers, to merge sets of headers, and to format a set
+;; of headers.
+
+;; The car of each element in the message-header alist is a symbol whose
+;; print name is the name of the header, in all lower-case. The cdr of an
+;; element depends on the operation. After extracting headers from a
+;; messge, it is a string, the value of the header. An extracted set of
+;; headers may be parsed further, which may turn it into a list, whose car
+;; is the original value and whose subsequent elements depend on the
+;; header. For formatting, it is evaluated to obtain the strings to be
+;; inserted. For merging, one set of headers consists of strings, while
+;; the other set will be evaluated with the symbols in the first set of
+;; headers bound to their respective values.
+
+;;; Code:
+
+(require 'cl)
+
+;; Make the byte-compiler shut up.
+(defvar headers)
+
+(defun mail-header-extract ()
+ "Extract headers from current buffer after point.
+Returns a header alist, where each element is a cons cell (name . value),
+where NAME is a symbol, and VALUE is the string value of the header having
+that name."
+ (let ((message-headers ()) (top (point))
+ start end)
+ (while (and (setq start (point))
+ (> (skip-chars-forward "^\0- :") 0)
+ (= (following-char) ?:)
+ (setq end (point))
+ (progn (forward-char)
+ (> (skip-chars-forward " \t") 0)))
+ (let ((header (intern (downcase (buffer-substring start end))))
+ (value (list (buffer-substring
+ (point) (progn (end-of-line) (point))))))
+ (while (progn (forward-char) (> (skip-chars-forward " \t") 0))
+ (push (buffer-substring (point) (progn (end-of-line) (point)))
+ value))
+ (push (if (cdr value)
+ (cons header (mapconcat #'identity (nreverse value) " "))
+ (cons header (car value)))
+ message-headers)))
+ (goto-char top)
+ (nreverse message-headers)))
+
+(defun mail-header-extract-no-properties ()
+ "Extract headers from current buffer after point, without properties.
+Returns a header alist, where each element is a cons cell (name . value),
+where NAME is a symbol, and VALUE is the string value of the header having
+that name."
+ (mapcar
+ (lambda (elt)
+ (set-text-properties 0 (length (cdr elt)) nil (cdr elt))
+ elt)
+ (mail-header-extract)))
+
+(defun mail-header-parse (parsing-rules headers)
+ "Apply PARSING-RULES to HEADERS.
+PARSING-RULES is an alist whose keys are header names (symbols) and whose
+value is a parsing function. The function takes one argument, a string,
+and return a list of values, which will destructively replace the value
+associated with the key in HEADERS, after being prepended with the original
+value."
+ (dolist (rule parsing-rules)
+ (let ((header (assq (car rule) headers)))
+ (when header
+ (if (consp (cdr header))
+ (setf (cddr header) (funcall (cdr rule) (cadr header)))
+ (setf (cdr header)
+ (cons (cdr header) (funcall (cdr rule) (cdr header))))))))
+ headers)
+
+(defsubst mail-header (header &optional header-alist)
+ "Return the value associated with header HEADER in HEADER-ALIST.
+If the value is a string, it is the original value of the header. If the
+value is a list, its first element is the original value of the header,
+with any subsequent elements bing the result of parsing the value.
+If HEADER-ALIST is nil, the dynamically bound variable `headers' is used."
+ (cdr (assq header (or header-alist headers))))
+
+(defun mail-header-set (header value &optional header-alist)
+ "Set the value associated with header HEADER to VALUE in HEADER-ALIST.
+HEADER-ALIST defaults to the dynamically bound variable `headers' if nil.
+See `mail-header' for the semantics of VALUE."
+ (let* ((alist (or header-alist headers))
+ (entry (assq header alist)))
+ (if entry
+ (setf (cdr entry) value)
+ (nconc alist (list (cons header value)))))
+ value)
+
+(defsetf mail-header (header &optional header-alist) (value)
+ `(mail-header-set ,header ,value ,header-alist))
+
+(defun mail-header-merge (merge-rules headers)
+ "Return a new header alist with MERGE-RULES applied to HEADERS.
+MERGE-RULES is an alist whose keys are header names (symbols) and whose
+values are forms to evaluate, the results of which are the new headers. It
+should be a string or a list of string. The first element may be nil to
+denote that the formatting functions must use the remaining elements, or
+skip the header altogether if there are no other elements.
+ The macro `mail-header' can be used to access headers in HEADERS."
+ (mapcar
+ (lambda (rule)
+ (cons (car rule) (eval (cdr rule))))
+ merge-rules))
+
+(defvar mail-header-format-function
+ (lambda (header value)
+ "Function to format headers without a specified formatting function."
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")))
+
+(defun mail-header-format (format-rules headers)
+ "Use FORMAT-RULES to format HEADERS and insert into current buffer.
+FORMAT-RULES is an alist whose keys are header names (symbols), and whose
+values are functions that format the header, the results of which are
+inserted, unless it is nil. The function takes two arguments, the header
+symbol, and the value of that header. If the function itself is nil, the
+default action is to insert the value of the header, unless it is nil.
+The headers are inserted in the order of the FORMAT-RULES.
+A key of t represents any otherwise unmentioned headers.
+A key of nil has as its value a list of defaulted headers to ignore."
+ (let ((ignore (append (cdr (assq nil format-rules))
+ (mapcar #'car format-rules))))
+ (dolist (rule format-rules)
+ (let* ((header (car rule))
+ (value (mail-header header)))
+ (cond ((null header) 'ignore)
+ ((eq header t)
+ (dolist (defaulted headers)
+ (unless (memq (car defaulted) ignore)
+ (let* ((header (car defaulted))
+ (value (cdr defaulted)))
+ (if (cdr rule)
+ (funcall (cdr rule) header value)
+ (funcall mail-header-format-function header value))))))
+ (value
+ (if (cdr rule)
+ (funcall (cdr rule) header value)
+ (funcall mail-header-format-function header value))))))
+ (insert "\n")))
+
+(provide 'mailheader)
+
+;;; mail-header.el ends here
--- /dev/null
+;;; message.el --- composing mail and news messages
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: mail, 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:
+
+;; This mode provides mail-sending facilities from within Emacs. It
+;; consists mainly of large chunks of code from the sendmail.el,
+;; gnus-msg.el and rnewspost.el files.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(require 'mailheader)
+(require 'rmail)
+(require 'nnheader)
+(require 'timezone)
+(require 'easymenu)
+(if (string-match "XEmacs\\|Lucid" emacs-version)
+ (require 'mail-abbrevs)
+ (require 'mailabbrev))
+
+;;;###autoload
+(defvar message-directory "~/Mail/"
+ "*Directory from which all other mail file variables are derived.")
+
+(defvar message-max-buffers 10
+ "*How many buffers to keep before starting to kill them off.")
+
+(defvar message-send-rename-function nil
+ "Function called to rename the buffer after sending it.")
+
+;;;###autoload
+(defvar message-fcc-handler-function 'rmail-output
+ "*A function called to save outgoing articles.
+This function will be called with the name of the file to store the
+article in. The default function is `rmail-output' which saves in Unix
+mailbox format.")
+
+;;;###autoload
+(defvar message-courtesy-message
+ "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
+ "*This is inserted at the start of a mailed copy of a posted message.
+If this variable is nil, no such courtesy message will be added.")
+
+;;;###autoload
+(defvar message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"
+ "*Regexp that matches headers to be removed in resent bounced mail.")
+
+;;;###autoload
+(defvar message-from-style 'default
+ "*Specifies how \"From\" headers look.
+
+If `nil', they contain just the return address like:
+ king@grassland.com
+If `parens', they look like:
+ king@grassland.com (Elvis Parsley)
+If `angles', they look like:
+ Elvis Parsley <king@grassland.com>
+
+Otherwise, most addresses look like `angles', but they look like
+`parens' if `angles' would need quoting and `parens' would not.")
+
+;;;###autoload
+(defvar message-syntax-checks nil
+ "Controls what syntax checks should not be performed on outgoing posts.
+To disable checking of long signatures, for instance, add
+ `(signature . disabled)' to this list.
+
+Don't touch this variable unless you really know what you're doing.
+
+Checks include subject-cmsg multiple-headers sendsys message-id from
+long-lines control-chars size new-text redirected-followup signature
+approved sender empty empty-headers message-id from subject.")
+
+;;;###autoload
+(defvar message-required-news-headers
+ '(From Newsgroups Subject Date Message-ID
+ (optional . Organization) Lines
+ (optional . X-Newsreader))
+ "*Headers to be generated or prompted for when posting an article.
+RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
+Message-ID. Organization, Lines, In-Reply-To, Expires, and
+X-Newsreader are optional. If don't you want message to insert some
+header, remove it from this list.")
+
+;;;###autoload
+(defvar message-required-mail-headers
+ '(From Subject Date (optional . In-Reply-To) Message-ID Lines
+ (optional . X-Mailer))
+ "*Headers to be generated or prompted for when mailing a message.
+RFC822 required that From, Date, To, Subject and Message-ID be
+included. Organization, Lines and X-Mailer are optional.")
+
+;;;###autoload
+(defvar message-deletable-headers '(Message-ID Date)
+ "*Headers to be deleted if they already exist and were generated by message previously.")
+
+;;;###autoload
+(defvar message-ignored-news-headers
+ "^NNTP-Posting-Host:\\|^Xref:\\|^Bcc:\\|^Gcc:\\|^Fcc:"
+ "*Regexp of headers to be removed unconditionally before posting.")
+
+;;;###autoload
+(defvar message-ignored-mail-headers "^Gcc:\\|^Fcc:"
+ "*Regexp of headers to be removed unconditionally before mailing.")
+
+;;;###autoload
+(defvar message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|Return-Path:\\|^Supersedes:"
+ "*Header lines matching this regexp will be deleted before posting.
+It's best to delete old Path and Date headers before posting to avoid
+any confusion.")
+
+;;;###autoload
+(defvar message-signature-separator "^-- *$"
+ "Regexp matching the signature separator.")
+
+;;;###autoload
+(defvar message-interactive nil
+ "Non-nil means when sending a message wait for and display errors.
+nil means let mailer mail back a message to report errors.")
+
+;;;###autoload
+(defvar message-generate-new-buffers t
+ "*Non-nil means that a new message buffer will be created whenever `mail-setup' is called.
+If this is a function, call that function with three parameters: The type,
+the to address and the group name. (Any of these may be nil.) The function
+should return the new buffer name.")
+
+;;;###autoload
+(defvar message-kill-buffer-on-exit nil
+ "*Non-nil means that the message buffer will be killed after sending a message.")
+
+(defvar gnus-local-organization)
+(defvar message-user-organization
+ (or (and (boundp 'gnus-local-organization)
+ gnus-local-organization)
+ (getenv "ORGANIZATION")
+ t)
+ "*String to be used as an Organization header.
+If t, use `message-user-organization-file'.")
+
+;;;###autoload
+(defvar message-user-organization-file "/usr/lib/news/organization"
+ "*Local news organization file.")
+
+;;;###autoload
+(defvar message-autosave-directory
+ (concat (file-name-as-directory message-directory) "drafts/")
+ "*Directory where message autosaves buffers.
+If nil, message won't autosave.")
+
+(defvar message-forward-start-separator
+ "------- Start of forwarded message -------\n"
+ "*Delimiter inserted before forwarded messages.")
+
+(defvar message-forward-end-separator
+ "------- End of forwarded message -------\n"
+ "*Delimiter inserted after forwarded messages.")
+
+;;;###autoload
+(defvar message-signature-before-forwarded-message t
+ "*If non-nil, put the signature before any included forwarded message.")
+
+;;;###autoload
+(defvar message-included-forward-headers
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:"
+ "*Regexp matching headers to be included in forwarded messages.")
+
+;;;###autoload
+(defvar message-ignored-resent-headers "^Return-receipt"
+ "*All headers that match this regexp will be deleted when resending a message.")
+
+;;;###autoload
+(defvar message-ignored-cited-headers "."
+ "Delete these headers from the messages you yank.")
+
+;; Useful to set in site-init.el
+;;;###autoload
+(defvar message-send-mail-function 'message-send-mail-with-sendmail
+ "Function to call to send the current buffer as mail.
+The headers should be delimited by a line whose contents match the
+variable `mail-header-separator'.
+
+Legal values include `message-send-mail-with-mh' and
+`message-send-mail-with-sendmail', which is the default.")
+
+;;;###autoload
+(defvar message-send-news-function 'message-send-news
+ "Function to call to send the current buffer as news.
+The headers should be delimited by a line whose contents match the
+variable `mail-header-separator'.")
+
+;;;###autoload
+(defvar message-reply-to-function nil
+ "Function that should return a list of headers.
+This function should pick out addresses from the To, Cc, and From headers
+and respond with new To and Cc headers.")
+
+;;;###autoload
+(defvar message-wide-reply-to-function nil
+ "Function that should return a list of headers.
+This function should pick out addresses from the To, Cc, and From headers
+and respond with new To and Cc headers.")
+
+;;;###autoload
+(defvar message-followup-to-function nil
+ "Function that should return a list of headers.
+This function should pick out addresses from the To, Cc, and From headers
+and respond with new To and Cc headers.")
+
+;;;###autoload
+(defvar message-use-followup-to 'ask
+ "*Specifies what to do with Followup-To header.
+If nil, ignore the header. If it is t, use its value, but query before
+using the \"poster\" value. If it is the symbol `ask', query the user
+whether to ignore the \"poster\" value. If it is the symbol `use',
+always use the value.")
+
+(defvar gnus-post-method)
+(defvar gnus-select-method)
+;;;###autoload
+(defvar message-post-method
+ (cond ((and (boundp 'gnus-post-method)
+ gnus-post-method)
+ gnus-post-method)
+ ((boundp 'gnus-select-method)
+ gnus-select-method)
+ (t '(nnspool "")))
+ "Method used to post news.")
+
+;;;###autoload
+(defvar message-generate-headers-first nil
+ "*If non-nil, generate all possible headers before composing.")
+
+(defvar message-setup-hook nil
+ "Normal hook, run each time a new outgoing message is initialized.
+The function `message-setup' runs this hook.")
+
+(defvar message-signature-setup-hook nil
+ "Normal hook, run each time a new outgoing message is initialized.
+It is run after the headers have been inserted and before
+the signature is inserted.")
+
+(defvar message-mode-hook nil
+ "Hook run in message mode buffers.")
+
+(defvar message-header-hook nil
+ "Hook run in a message mode buffer narrowed to the headers.")
+
+(defvar message-header-setup-hook nil
+ "Hook called narrowed to the headers when setting up a message buffer.")
+
+;;;###autoload
+(defvar message-citation-line-function 'message-insert-citation-line
+ "*Function called to insert the \"Whomever writes:\" line.")
+
+;;;###autoload
+(defvar message-yank-prefix "> "
+ "*Prefix inserted on the lines of yanked messages.
+nil means use indentation.")
+
+(defvar message-indentation-spaces 3
+ "*Number of spaces to insert at the beginning of each cited line.
+Used by `message-yank-original' via `message-yank-cite'.")
+
+;;;###autoload
+(defvar message-cite-function 'message-cite-original
+ "*Function for citing an original message.")
+
+;;;###autoload
+(defvar message-indent-citation-function 'message-indent-citation
+ "*Function for modifying a citation just inserted in the mail buffer.
+This can also be a list of functions. Each function can find the
+citation between (point) and (mark t). And each function should leave
+point and mark around the citation text as modified.")
+
+(defvar message-abbrevs-loaded nil)
+
+;;;###autoload
+(defvar message-signature t
+ "*String to be inserted at the end of the message buffer.
+If t, the `message-signature-file' file will be inserted instead.
+If a function, the result from the function will be used instead.
+If a form, the result from the form will be used instead.")
+
+;;;###autoload
+(defvar message-signature-file "~/.signature"
+ "*File containing the text inserted at end of message. buffer.")
+
+(defvar message-distribution-function nil
+ "*Function called to return a Distribution header.")
+
+(defvar message-expires 14
+ "*Number of days before your article expires.")
+
+(defvar message-user-path nil
+ "If nil, use the NNTP server name in the Path header.
+If stringp, use this; if non-nil, use no host name (user name only).")
+
+(defvar message-reply-buffer nil)
+(defvar message-reply-headers nil)
+(defvar message-newsreader nil)
+(defvar message-mailer nil)
+(defvar message-sent-message-via nil)
+(defvar message-checksum nil)
+(defvar message-send-actions nil
+ "A list of actions to be performed upon successful sending of a message.")
+(defvar message-exit-actions nil
+ "A list of actions to be performed upon exiting after sending a message.")
+(defvar message-kill-actions nil
+ "A list of actions to be performed before killing a message buffer.")
+(defvar message-postpone-actions nil
+ "A list of actions to be performed after postponing a message.")
+
+;;;###autoload
+(defvar message-default-headers nil
+ "*A string containing header lines to be inserted in outgoing messages.
+It is inserted before you edit the message, so you can edit or delete
+these lines.")
+
+;;;###autoload
+(defvar message-default-mail-headers nil
+ "*A string of header lines to be inserted in outgoing mails.")
+
+;;;###autoload
+(defvar message-default-news-headers nil
+ "*A string of header lines to be inserted in outgoing news articles.")
+
+;; Note: could use /usr/ucb/mail instead of sendmail;
+;; options -t, and -v if not interactive.
+(defvar message-mailer-swallows-blank-line
+ (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)"
+ system-configuration)
+ (file-readable-p "/etc/sendmail.cf")
+ (let ((buffer (get-buffer-create " *temp*")))
+ (unwind-protect
+ (save-excursion
+ (set-buffer buffer)
+ (insert-file-contents "/etc/sendmail.cf")
+ (goto-char (point-min))
+ (let ((case-fold-search nil))
+ (re-search-forward "^OR\\>" nil t)))
+ (kill-buffer buffer))))
+ ;; According to RFC822, "The field-name must be composed of printable
+ ;; ASCII characters (i.e. characters that have decimal values between
+ ;; 33 and 126, except colon)", i.e. any chars except ctl chars,
+ ;; space, or colon.
+ '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
+ "Set this non-nil if the system's mailer runs the header and body together.
+\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
+The value should be an expression to test whether the problem will
+actually occur.")
+
+(defvar message-mode-syntax-table
+ (let ((table (copy-syntax-table text-mode-syntax-table)))
+ (modify-syntax-entry ?% ". " table)
+ table)
+ "Syntax table used while in Message mode.")
+
+(defvar message-font-lock-keywords
+ (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")))
+ (list '("^To:" . font-lock-function-name-face)
+ '("^[GBF]?[Cc][Cc]:\\|^Reply-To:" . font-lock-keyword-face)
+ '("^\\(Subject:\\)[ \t]*\\(.+\\)?"
+ (1 font-lock-comment-face) (2 font-lock-type-face nil t))
+ (list (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+ 1 'font-lock-comment-face)
+ (cons (concat "^[ \t]*"
+ "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
+ "[>|}].*")
+ 'font-lock-reference-face)
+ '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*"
+ . font-lock-string-face)))
+ "Additional expressions to highlight in Message mode.")
+
+(defvar message-face-alist
+ '((bold . bold-region)
+ (underline . underline-region)
+ (default . (lambda (b e)
+ (unbold-region b e)
+ (ununderline-region b e))))
+ "Alist of mail and news faces for facemenu.
+The cdr of ech entry is a function for applying the face to a region.")
+
+(defvar message-send-hook nil
+ "Hook run before sending messages.")
+
+(defvar message-sent-hook nil
+ "Hook run after sending messages.")
+
+;;; Internal variables.
+
+(defvar message-buffer-list nil)
+
+;;; Regexp matching the delimiter of messages in UNIX mail format
+;;; (UNIX From lines), minus the initial ^.
+(defvar message-unix-mail-delimiter
+ (let ((time-zone-regexp
+ (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?"
+ "\\|[-+]?[0-9][0-9][0-9][0-9]"
+ "\\|"
+ "\\) *")))
+ (concat
+ "From "
+
+ ;; Username, perhaps with a quoted section that can contain spaces.
+ "\\("
+ "[^ \n]*"
+ "\\(\\|\".*\"[^ \n]*\\)"
+ "\\|<[^<>\n]+>"
+ "\\) ?"
+
+ ;; The time the message was sent.
+ "\\([^ \n]*\\) *" ; day of the week
+ "\\([^ ]*\\) *" ; month
+ "\\([0-9]*\\) *" ; day of month
+ "\\([0-9:]*\\) *" ; time of day
+
+ ;; Perhaps a time zone, specified by an abbreviation, or by a
+ ;; numeric offset.
+ time-zone-regexp
+
+ ;; The year.
+ " [0-9][0-9]\\([0-9]*\\) *"
+
+ ;; On some systems the time zone can appear after the year, too.
+ time-zone-regexp
+
+ ;; Old uucp cruft.
+ "\\(remote from .*\\)?"
+
+ "\n")))
+
+(defvar message-unsent-separator
+ (concat "^ *---+ +Unsent message follows +---+ *$\\|"
+ "^ *---+ +Returned message +---+ *$\\|"
+ "^Start of returned message$\\|"
+ "^ *---+ +Original message +---+ *$\\|"
+ "^ *--+ +begin message +--+ *$\\|"
+ "^ *---+ +Original message follows +---+ *$\\|"
+ "^|? *---+ +Message text follows: +---+ *|?$")
+ "A regexp that matches the separator before the text of a failed message.")
+
+(defvar message-header-format-alist
+ `((Newsgroups)
+ (To . message-fill-address)
+ (Cc . message-fill-address)
+ (Subject)
+ (In-Reply-To)
+ (Fcc)
+ (Bcc)
+ (Date)
+ (Organization)
+ (Distribution)
+ (Lines)
+ (Expires)
+ (Message-ID)
+ (References . message-fill-header)
+ (X-Mailer)
+ (X-Newsreader))
+ "Alist used for formatting headers.")
+
+(eval-and-compile
+ (autoload 'message-setup-toolbar "messagexmas")
+ (autoload 'mh-send-letter "mh-comp"))
+
+\f
+
+;;;
+;;; Utility functions.
+;;;
+
+(defun message-point-at-bol ()
+ "Return point at the beginning of the line."
+ (let ((p (point)))
+ (beginning-of-line)
+ (prog1
+ (point)
+ (goto-char p))))
+
+(defun message-point-at-eol ()
+ "Return point at the end of the line."
+ (let ((p (point)))
+ (end-of-line)
+ (prog1
+ (point)
+ (goto-char p))))
+
+;; Delete the current line (and the next N lines.);
+(defmacro message-delete-line (&optional n)
+ `(delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line ,(or n 1)) (point))))
+
+(defun message-tokenize-header (header &optional separator)
+ "Split HEADER into a list of header elements.
+\",\" is used as the separator."
+ (let ((regexp (format "[%s]+" (or separator ",")))
+ (beg 1)
+ quoted elems)
+ (save-excursion
+ (message-set-work-buffer)
+ (insert header)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (forward-char 1)
+ (cond ((and (> (point) beg)
+ (or (eobp)
+ (and (looking-at regexp)
+ (not quoted))))
+ (push (buffer-substring beg (point)) elems)
+ (setq beg (match-end 0)))
+ ((= (following-char) ?\")
+ (setq quoted (not quoted)))))
+ (nreverse elems))))
+
+(defun message-fetch-field (header)
+ "The same as `mail-fetch-field', only remove all newlines."
+ (let ((value (mail-fetch-field header)))
+ (when value
+ (nnheader-replace-chars-in-string value ?\n ? ))))
+
+(defun message-fetch-reply-field (header)
+ "Fetch FIELD from the message we're replying to."
+ (when (and message-reply-buffer
+ (buffer-name message-reply-buffer))
+ (save-excursion
+ (set-buffer message-reply-buffer)
+ (message-fetch-field header))))
+
+(defun message-set-work-buffer ()
+ (if (get-buffer " *message work*")
+ (progn
+ (set-buffer " *message work*")
+ (erase-buffer))
+ (set-buffer (get-buffer-create " *message work*"))
+ (kill-all-local-variables)
+ (buffer-disable-undo (current-buffer))))
+
+(defun message-functionp (form)
+ "Return non-nil if FORM is funcallable."
+ (or (and (symbolp form) (fboundp form))
+ (and (listp form) (eq (car form) 'lambda))))
+
+(defun message-strip-subject-re (subject)
+ "Remove \"Re:\" from subject lines."
+ (if (string-match "^[Rr][Ee]: *" subject)
+ (substring subject (match-end 0))
+ subject))
+
+(defun message-remove-header (header &optional is-regexp first reverse)
+ "Remove HEADER in the narrowed buffer.
+If REGEXP, HEADER is a regular expression.
+If FIRST, only remove the first instance of the header.
+Return the number of headers removed."
+ (goto-char (point-min))
+ (let ((regexp (if is-regexp header (concat "^" header ":")))
+ (number 0)
+ (case-fold-search t)
+ last)
+ (while (and (not (eobp))
+ (not last))
+ (if (if reverse
+ (not (looking-at regexp))
+ (looking-at regexp))
+ (progn
+ (incf number)
+ (when first
+ (setq last t))
+ (delete-region
+ (point)
+ ;; There might be a continuation header, so we have to search
+ ;; until we find a new non-continuation line.
+ (progn
+ (forward-line 1)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (goto-char (match-beginning 0))
+ (point-max)))))
+ (forward-line 1)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (goto-char (match-beginning 0))
+ (point-max))))
+ number))
+
+(defun message-narrow-to-headers ()
+ "Narrow the buffer to the head of the message."
+ (widen)
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (match-beginning 0)
+ (point-max)))
+ (goto-char (point-min)))
+
+(defun message-narrow-to-head ()
+ "Narrow the buffer to the head of the message."
+ (widen)
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil 1)
+ (1- (point))
+ (point-max)))
+ (goto-char (point-min)))
+
+(defun message-news-p ()
+ "Say whether the current buffer contains a news message."
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (message-fetch-field "newsgroups"))))
+
+(defun message-mail-p ()
+ "Say whether the current buffer contains a mail message."
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (or (message-fetch-field "to")
+ (message-fetch-field "cc")
+ (message-fetch-field "bcc")))))
+
+(defun message-next-header ()
+ "Go to the beginning of the next header."
+ (beginning-of-line)
+ (or (eobp) (forward-char 1))
+ (not (if (re-search-forward "^[^ \t]" nil t)
+ (beginning-of-line)
+ (goto-char (point-max)))))
+
+(defun message-sort-headers-1 ()
+ "Sort the buffer as headers using `message-rank' text props."
+ (goto-char (point-min))
+ (sort-subr
+ nil 'message-next-header
+ (lambda ()
+ (message-next-header)
+ (unless (bobp)
+ (forward-char -1)))
+ (lambda ()
+ (or (get-text-property (point) 'message-rank)
+ 0))))
+
+(defun message-sort-headers ()
+ "Sort the headers of the current message according to `message-header-format-alist'."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (let ((max (1+ (length message-header-format-alist)))
+ rank)
+ (message-narrow-to-headers)
+ (while (re-search-forward "^[^ \n]+:" nil t)
+ (put-text-property
+ (match-beginning 0) (1+ (match-beginning 0))
+ 'message-rank
+ (if (setq rank (length (memq (assq (intern (buffer-substring
+ (match-beginning 0)
+ (1- (match-end 0))))
+ message-header-format-alist)
+ message-header-format-alist)))
+ (- max rank)
+ (1+ max)))))
+ (message-sort-headers-1))))
+
+\f
+
+;;;
+;;; Message mode
+;;;
+
+;;; Set up keymap.
+
+(defvar message-mode-map nil)
+
+(unless message-mode-map
+ (setq message-mode-map (copy-keymap text-mode-map))
+ (define-key message-mode-map "\C-c?" 'describe-mode)
+
+ (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
+ (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
+ (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
+ (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
+ (define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
+ (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
+ (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
+ (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
+ (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
+ (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
+ (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
+ (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
+ (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
+
+ (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
+ (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
+
+ (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
+ (define-key message-mode-map "\C-c\C-q" 'message-fill-yanked-message)
+ (define-key message-mode-map "\C-c\C-w" 'message-insert-signature)
+ (define-key message-mode-map "\C-c\C-r" 'message-caesar-buffer-body)
+ (define-key message-mode-map "\C-c\C-o" 'message-sort-headers)
+ (define-key message-mode-map "\C-c\M-r" 'message-rename-buffer)
+
+ (define-key message-mode-map "\C-c\C-c" 'message-send-and-exit)
+ (define-key message-mode-map "\C-c\C-s" 'message-send)
+ (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
+ (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
+
+ (define-key message-mode-map "\t" 'message-tab))
+
+(easy-menu-define message-mode-menu message-mode-map
+ "Message Menu."
+ '("Message"
+ "Go to Field:"
+ "----"
+ ["To" message-goto-to t]
+ ["Subject" message-goto-subject t]
+ ["Cc" message-goto-cc t]
+ ["Reply-to" message-goto-reply-to t]
+ ["Summary" message-goto-summary t]
+ ["Keywords" message-goto-keywords t]
+ ["Newsgroups" message-goto-newsgroups t]
+ ["Followup-To" message-goto-followup-to t]
+ ["Distribution" message-goto-distribution t]
+ ["Body" message-goto-body t]
+ ["Signature" message-goto-signature t]
+ "----"
+ "Miscellaneous Commands:"
+ "----"
+ ["Sort Headers" message-sort-headers t]
+ ["Yank Original" message-yank-original t]
+ ["Fill Yanked Message" message-fill-yanked-message t]
+ ["Insert Signature" message-insert-signature t]
+ ["Caesar (rot13) Message" message-caesar-buffer-body t]
+ ["Rename buffer" message-rename-buffer t]
+ ["Spellcheck" ispell-message t]
+ "----"
+ ["Send Message" message-send-and-exit t]
+ ["Abort Message" message-dont-send t]))
+
+(defvar facemenu-add-face-function)
+(defvar facemenu-remove-face-function)
+
+;;;###autoload
+(defun message-mode ()
+ "Major mode for editing mail and news to be sent.
+Like Text Mode but with these additional commands:
+C-c C-s message-send (send the message) C-c C-c message-send-and-exit
+C-c C-f move to a header field (and create it if there isn't):
+ C-c C-f C-t move to To C-c C-f C-s move to Subject
+ C-c C-f C-c move to Cc C-c C-f C-b move to Bcc
+ C-c C-f C-f move to Fcc C-c C-f C-r move to Reply-To
+ C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
+ C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
+ C-c C-f C-o move to Followup-To
+C-c C-t message-insert-to (add a To header to a news followup)
+C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply)
+C-c C-b message-goto-body (move to beginning of message text).
+C-c C-i message-goto-signature (move to the beginning of the signature).
+C-c C-w message-insert-signature (insert `message-signature-file' file).
+C-c C-y message-yank-original (insert current message, if any).
+C-c C-q message-fill-yanked-message (fill what was yanked).
+C-c C-r message-ceasar-buffer-body (rot13 the message body)."
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'message-reply-buffer)
+ (setq message-reply-buffer nil)
+ (make-local-variable 'message-send-actions)
+ (make-local-variable 'message-exit-actions)
+ (make-local-variable 'message-kill-actions)
+ (make-local-variable 'message-postpone-actions)
+ (set-syntax-table message-mode-syntax-table)
+ (use-local-map message-mode-map)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (setq major-mode 'message-mode)
+ (setq mode-name "Message")
+ (setq buffer-offer-save t)
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults '(message-font-lock-keywords t))
+ (make-local-variable 'facemenu-add-face-function)
+ (make-local-variable 'facemenu-remove-face-function)
+ (setq facemenu-add-face-function
+ (lambda (face end)
+ (let ((face-fun (cdr (assq face message-face-alist))))
+ (if face-fun
+ (funcall face-fun (point) end)
+ (error "Face %s not configured for %s mode" face mode-name)))
+ "")
+ facemenu-remove-face-function t)
+ (make-local-variable 'paragraph-separate)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat (regexp-quote mail-header-separator)
+ "$\\|[ \t]*[-_][-_][-_]+$\\|"
+ "-- $\\|"
+ paragraph-start))
+ (setq paragraph-separate (concat (regexp-quote mail-header-separator)
+ "$\\|[ \t]*[-_][-_][-_]+$\\|"
+ "-- $\\|"
+ paragraph-separate))
+ (make-local-variable 'message-reply-headers)
+ (setq message-reply-headers nil)
+ (make-local-variable 'message-newsreader)
+ (make-local-variable 'message-mailer)
+ (make-local-variable 'message-post-method)
+ (make-local-variable 'message-sent-message-via)
+ (setq message-sent-message-via nil)
+ (make-local-variable 'message-checksum)
+ (setq message-checksum nil)
+ (when (fboundp 'mail-hist-define-keys)
+ (mail-hist-define-keys))
+ (when (string-match "XEmacs\\|Lucid" emacs-version)
+ (message-setup-toolbar))
+ (easy-menu-add message-mode-menu message-mode-map)
+ ;; Allow mail alias things.
+ (if (fboundp 'mail-abbrevs-setup)
+ (mail-abbrevs-setup)
+ (funcall (intern "mail-aliases-setup")))
+ (run-hooks 'text-mode-hook 'message-mode-hook))
+
+\f
+
+;;;
+;;; Message mode commands
+;;;
+
+;;; Movement commands
+
+(defun message-goto-to ()
+ "Move point to the To header."
+ (interactive)
+ (message-position-on-field "To"))
+
+(defun message-goto-subject ()
+ "Move point to the Subject header."
+ (interactive)
+ (message-position-on-field "Subject"))
+
+(defun message-goto-cc ()
+ "Move point to the Cc header."
+ (interactive)
+ (message-position-on-field "Cc" "To"))
+
+(defun message-goto-bcc ()
+ "Move point to the Bcc header."
+ (interactive)
+ (message-position-on-field "Bcc" "Cc" "To"))
+
+(defun message-goto-fcc ()
+ "Move point to the Fcc header."
+ (interactive)
+ (message-position-on-field "Fcc" "To" "Newsgroups"))
+
+(defun message-goto-reply-to ()
+ "Move point to the Reply-To header."
+ (interactive)
+ (message-position-on-field "Reply-To" "Subject"))
+
+(defun message-goto-newsgroups ()
+ "Move point to the Newsgroups header."
+ (interactive)
+ (message-position-on-field "Newsgroups"))
+
+(defun message-goto-distribution ()
+ "Move point to the Distribution header."
+ (interactive)
+ (message-position-on-field "Distribution"))
+
+(defun message-goto-followup-to ()
+ "Move point to the Followup-To header."
+ (interactive)
+ (message-position-on-field "Followup-To" "Newsgroups"))
+
+(defun message-goto-keywords ()
+ "Move point to the Keywords header."
+ (interactive)
+ (message-position-on-field "Keywords" "Subject"))
+
+(defun message-goto-summary ()
+ "Move point to the Summary header."
+ (interactive)
+ (message-position-on-field "Summary" "Subject"))
+
+(defun message-goto-body ()
+ "Move point to the beginning of the message body."
+ (interactive)
+ (if (looking-at "[ \t]*\n") (expand-abbrev))
+ (goto-char (point-min))
+ (search-forward (concat "\n" mail-header-separator "\n") nil t))
+
+(defun message-goto-signature ()
+ "Move point to the beginning of the message signature."
+ (interactive)
+ (goto-char (point-min))
+ (or (re-search-forward message-signature-separator nil t)
+ (goto-char (point-max))))
+
+\f
+
+(defun message-insert-to ()
+ "Insert a To header that points to the author of the article being replied to."
+ (interactive)
+ (when (and (message-position-on-field "To")
+ (mail-fetch-field "to")
+ (not (string-match "\\` *\\'" (mail-fetch-field "to"))))
+ (insert ", "))
+ (insert (or (message-fetch-reply-field "reply-to")
+ (message-fetch-reply-field "from") "")))
+
+(defun message-insert-newsgroups ()
+ "Insert the Newsgroups header from the article being replied to."
+ (interactive)
+ (when (and (message-position-on-field "Newsgroups")
+ (mail-fetch-field "newsgroups")
+ (not (string-match "\\` *\\'" (mail-fetch-field "newsgroups"))))
+ (insert ","))
+ (insert (or (message-fetch-reply-field "newsgroups") "")))
+
+\f
+
+;;; Various commands
+
+(defun message-insert-signature (&optional force)
+ "Insert a signature. See documentation for the `message-signature' variable."
+ (interactive (list 0))
+ (let* ((signature
+ (cond ((and (null message-signature)
+ (eq force 0))
+ (save-excursion
+ (goto-char (point-max))
+ (not (re-search-backward
+ message-signature-separator nil t))))
+ ((and (null message-signature)
+ force)
+ t)
+ ((message-functionp message-signature)
+ (funcall message-signature))
+ ((listp message-signature)
+ (eval message-signature))
+ (t message-signature)))
+ (signature
+ (cond ((stringp signature)
+ signature)
+ ((and (eq t signature)
+ message-signature-file
+ (file-exists-p message-signature-file))
+ signature))))
+ (when signature
+; ;; Remove blank lines at the end of the message.
+ (goto-char (point-max))
+; (skip-chars-backward " \t\n")
+; (delete-region (point) (point-max))
+ ;; Insert the signature.
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n-- \n")
+ (if (eq signature t)
+ (insert-file-contents message-signature-file)
+ (insert signature))
+ (goto-char (point-max))
+ (or (bolp) (insert "\n")))))
+
+(defvar message-caesar-translation-table nil)
+
+(defun message-caesar-region (b e &optional n)
+ "Caesar rotation of region by N, default 13, for decrypting netnews."
+ (interactive
+ (list
+ (min (point) (or (mark t) (point)))
+ (max (point) (or (mark t) (point)))
+ (when current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))))
+
+ (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
+ (unless (or (zerop n) ; no action needed for a rot of 0
+ (= b e)) ; no region to rotate
+ ;; We build the table, if necessary.
+ (when (or (not message-caesar-translation-table)
+ (/= (aref message-caesar-translation-table ?a) (+ ?a n)))
+ (let ((i -1)
+ (table (make-string 256 0)))
+ (while (< (incf i) 256)
+ (aset table i i))
+ (setq table
+ (concat
+ (substring table 0 ?A)
+ (substring table (+ ?A n) (+ ?A n (- 26 n)))
+ (substring table ?A (+ ?A n))
+ (substring table (+ ?A 26) ?a)
+ (substring table (+ ?a n) (+ ?a n (- 26 n)))
+ (substring table ?a (+ ?a n))
+ (substring table (+ ?a 26) 255)))
+ (setq message-caesar-translation-table table)))
+ ;; Then we translate the region. Do it this way to retain
+ ;; text properties.
+ (while (< b e)
+ (subst-char-in-region
+ b (1+ b) (char-after b)
+ (aref message-caesar-translation-table (char-after b)))
+ (incf b))))
+
+(defun message-caesar-buffer-body (&optional rotnum)
+ "Caesar rotates all letters in the current buffer by 13 places.
+Used to encode/decode possibly offensive messages (commonly in net.jokes).
+With prefix arg, specifies the number of places to rotate each letter forward.
+Mail and USENET news headers are not rotated."
+ (interactive (if current-prefix-arg
+ (list (prefix-numeric-value current-prefix-arg))
+ (list nil)))
+ (save-excursion
+ (save-restriction
+ (when (message-goto-body)
+ (narrow-to-region (point) (point-max)))
+ (message-caesar-region (point-min) (point-max) rotnum))))
+
+(defun message-rename-buffer (&optional enter-string)
+ "Rename the *message* buffer to \"*message* RECIPIENT\".
+If the function is run with a prefix, it will ask for a new buffer
+name, rather than giving an automatic name."
+ (interactive "Pbuffer name: ")
+ (save-excursion
+ (save-restriction
+ (goto-char (point-min))
+ (narrow-to-region (point)
+ (search-forward mail-header-separator nil 'end))
+ (let* ((mail-to (if (message-news-p) (message-fetch-field "Newsgroups")
+ (message-fetch-field "To")))
+ (mail-trimmed-to
+ (if (string-match "," mail-to)
+ (concat (substring mail-to 0 (match-beginning 0)) ", ...")
+ mail-to))
+ (name-default (concat "*message* " mail-trimmed-to))
+ (name (if enter-string
+ (read-string "New buffer name: " name-default)
+ name-default)))
+ (rename-buffer name t)))))
+
+(defun message-fill-yanked-message (&optional justifyp)
+ "Fill the paragraphs of a message yanked into this one.
+Numeric argument means justify as well."
+ (interactive "P")
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward (concat "\n" mail-header-separator "\n") nil t)
+ (let ((fill-prefix message-yank-prefix))
+ (fill-individual-paragraphs (point) (point-max) justifyp t))))
+
+(defun message-indent-citation ()
+ "Modify text just inserted from a message to be cited.
+The inserted text should be the region.
+When this function returns, the region is again around the modified text.
+
+Normally, indent each nonblank line `message-indentation-spaces' spaces.
+However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
+ (let ((start (point)))
+ ;; Remove unwanted headers.
+ (when message-ignored-cited-headers
+ (save-restriction
+ (narrow-to-region
+ (goto-char start)
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point)))
+ (message-remove-header message-ignored-cited-headers t)))
+ ;; Do the indentation.
+ (if (null message-yank-prefix)
+ (indent-rigidly start (mark t) message-indentation-spaces)
+ (save-excursion
+ (goto-char start)
+ (while (< (point) (mark t))
+ (insert message-yank-prefix)
+ (forward-line 1)))
+ (goto-char start))))
+
+(defun message-yank-original (&optional arg)
+ "Insert the message being replied to, if any.
+Puts point before the text and mark after.
+Normally indents each nonblank line ARG spaces (default 3). However,
+if `message-yank-prefix' is non-nil, insert that prefix on each line.
+
+Just \\[universal-argument] as argument means don't indent, insert no
+prefix, and don't delete any headers."
+ (interactive "P")
+ (let ((modified (buffer-modified-p)))
+ (when (and message-reply-buffer
+ message-cite-function)
+ (delete-windows-on message-reply-buffer t)
+ (insert-buffer message-reply-buffer)
+ (funcall message-cite-function)
+ (message-exchange-point-and-mark)
+ (unless (bolp)
+ (insert ?\n))
+ (unless modified
+ (setq message-checksum (cons (message-checksum) (buffer-size)))))))
+
+(defun message-cite-original ()
+ (let ((start (point))
+ (functions
+ (when message-indent-citation-function
+ (if (listp message-indent-citation-function)
+ message-indent-citation-function
+ (list message-indent-citation-function)))))
+ (goto-char start)
+ (while functions
+ (funcall (pop functions)))
+ (when message-citation-line-function
+ (unless (bolp)
+ (insert "\n"))
+ (funcall message-citation-line-function))))
+
+(defun message-insert-citation-line ()
+ "Function that inserts a simple citation line."
+ (when message-reply-headers
+ (insert (mail-header-from message-reply-headers) " writes:\n\n")))
+
+(defun message-position-on-field (header &rest afters)
+ (let ((case-fold-search t))
+ (save-restriction
+ (narrow-to-region
+ (goto-char (point-min))
+ (progn
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (match-beginning 0)))
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" (regexp-quote header) ":") nil t)
+ (progn
+ (re-search-forward "^[^ \t]" nil 'move)
+ (beginning-of-line)
+ (skip-chars-backward "\n")
+ t)
+ (while (and afters
+ (not (re-search-forward
+ (concat "^" (regexp-quote (car afters)) ":")
+ nil t)))
+ (pop afters))
+ (when afters
+ (re-search-forward "^[^ \t]" nil 'move)
+ (beginning-of-line))
+ (insert header ": \n")
+ (forward-char -1)
+ nil))))
+
+(defun message-remove-signature ()
+ "Remove the signature from the text between point and mark.
+The text will also be indented the normal way."
+ (save-excursion
+ (let ((start (point))
+ mark)
+ (if (not (re-search-forward message-signature-separator (mark t) t))
+ ;; No signature here, so we just indent the cited text.
+ (message-indent-citation)
+ ;; Find the last non-empty line.
+ (forward-line -1)
+ (while (looking-at "[ \t]*$")
+ (forward-line -1))
+ (forward-line 1)
+ (setq mark (set-marker (make-marker) (point)))
+ (goto-char start)
+ (message-indent-citation)
+ ;; Enable undoing the deletion.
+ (undo-boundary)
+ (delete-region mark (mark t))
+ (set-marker mark nil)))))
+
+\f
+
+;;;
+;;; Sending messages
+;;;
+
+(defun message-send-and-exit (&optional arg)
+ "Send message like `message-send', then, if no errors, exit from mail buffer."
+ (interactive "P")
+ (let ((buf (current-buffer))
+ (actions message-exit-actions))
+ (when (and (message-send arg)
+ (buffer-name buf))
+ (if message-kill-buffer-on-exit
+ (kill-buffer buf)
+ (bury-buffer buf)
+ (when (eq buf (current-buffer))
+ (message-bury buf)))
+ (message-do-actions actions))))
+
+(defun message-dont-send ()
+ "Don't send the message you have been editing."
+ (interactive)
+ (message-bury (current-buffer))
+ (message-do-actions message-postpone-actions))
+
+(defun message-kill-buffer ()
+ "Kill the current buffer."
+ (interactive)
+ (let ((actions message-kill-actions))
+ (kill-buffer (current-buffer))
+ (message-do-actions actions)))
+
+(defun message-bury (buffer)
+ "Bury this mail buffer."
+ (let ((newbuf (other-buffer buffer)))
+ (bury-buffer buffer)
+ (if (and (fboundp 'frame-parameters)
+ (cdr (assq 'dedicated (frame-parameters)))
+ (not (null (delq (selected-frame) (visible-frame-list)))))
+ (delete-frame (selected-frame))
+ (switch-to-buffer newbuf))))
+
+(defun message-send (&optional arg)
+ "Send the message in the current buffer.
+If `message-interactive' is non-nil, wait for success indication
+or error messages, and inform user.
+Otherwise any failure is reported in a message back to
+the user from the mailer."
+ (interactive "P")
+ (when (if buffer-file-name
+ (y-or-n-p (format "Send buffer contents as %s message? "
+ (if (message-mail-p)
+ (if (message-news-p) "mail and news" "mail")
+ "news")))
+ (or (buffer-modified-p)
+ (y-or-n-p "No changes in the buffer; really send? ")))
+ ;; Make it possible to undo the coming changes.
+ (undo-boundary)
+ (let ((inhibit-read-only t))
+ (put-text-property (point-min) (point-max) 'read-only nil))
+ (message-fix-before-sending)
+ (run-hooks 'message-send-hook)
+ (message "Sending...")
+ (when (and (or (not (message-news-p))
+ (and (or (not (memq 'news message-sent-message-via))
+ (y-or-n-p
+ "Already sent message via news; resend? "))
+ (funcall message-send-news-function arg)))
+ (or (not (message-mail-p))
+ (and (or (not (memq 'mail message-sent-message-via))
+ (y-or-n-p
+ "Already sent message via mail; resend? "))
+ (message-send-mail arg))))
+ (message-do-fcc)
+ (when (fboundp 'mail-hist-put-headers-into-history)
+ (mail-hist-put-headers-into-history))
+ (run-hooks 'message-sent-hook)
+ (message "Sending...done")
+ ;; If buffer has no file, mark it as unmodified and delete autosave.
+ (unless buffer-file-name
+ (set-buffer-modified-p nil)
+ (delete-auto-save-file-if-necessary t))
+ ;; Delete other mail buffers and stuff.
+ (message-do-send-housekeeping)
+ (message-do-actions message-send-actions)
+ ;; Return success.
+ t)))
+
+(defun message-fix-before-sending ()
+ "Do various things to make the message nice before sending it."
+ ;; Make sure there's a newline at the end of the message.
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n")))
+
+(defun message-add-action (action &rest types)
+ "Add ACTION to be performed when doing an exit of type TYPES."
+ (let (var)
+ (while types
+ (set (setq var (intern (format "message-%s-actions" (pop types))))
+ (nconc (symbol-value var) (list action))))))
+
+(defun message-do-actions (actions)
+ "Perform all actions in ACTIONS."
+ ;; Now perform actions on successful sending.
+ (while actions
+ (condition-case nil
+ (cond
+ ;; A simple function.
+ ((message-functionp (car actions))
+ (funcall (car actions)))
+ ;; Something to be evaled.
+ (t
+ (eval (car actions))))
+ (error))
+ (pop actions)))
+
+(defun message-send-mail (&optional arg)
+ (require 'mail-utils)
+ (let ((tembuf (generate-new-buffer " message temp"))
+ (case-fold-search nil)
+ (news (message-news-p))
+ (mailbuf (current-buffer)))
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Insert some headers.
+ (let ((message-deletable-headers
+ (if news nil message-deletable-headers)))
+ (message-generate-headers message-required-mail-headers))
+ ;; Let the user do all of the above.
+ (run-hooks 'message-header-hook))
+ (unwind-protect
+ (save-excursion
+ (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
+ (or (message-fetch-field "cc")
+ (message-fetch-field "to")))
+ (message-insert-courtesy-copy))
+ (funcall message-send-mail-function))
+ (kill-buffer tembuf))
+ (set-buffer mailbuf)
+ (push 'mail message-sent-message-via)))
+
+(defun message-send-mail-with-sendmail ()
+ "Send off the prepared buffer with sendmail."
+ (let ((errbuf (if message-interactive
+ (generate-new-buffer " sendmail errors")
+ 0))
+ resend-to-addresses delimline)
+ (let ((case-fold-search t))
+ (save-restriction
+ (message-narrow-to-headers)
+ (setq resend-to-addresses (message-fetch-field "resent-to")))
+ ;; 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))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ (let ((default-directory "/"))
+ (apply 'call-process-region
+ (append (list (point-min) (point-max)
+ (if (boundp 'sendmail-program)
+ sendmail-program
+ "/usr/lib/sendmail")
+ nil errbuf nil "-oi")
+ ;; Always specify who from,
+ ;; since some systems have broken sendmails.
+ (list "-f" (user-login-name))
+ ;; These mean "report errors by mail"
+ ;; and "deliver in background".
+ (if (null message-interactive) '("-oem" "-odb"))
+ ;; Get the addresses from the message
+ ;; unless this is a resend.
+ ;; We must not do that for a resend
+ ;; because we would find the original addresses.
+ ;; For a resend, include the specific addresses.
+ (if resend-to-addresses
+ (list resend-to-addresses)
+ '("-t")))))
+ (when message-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (goto-char (point-min))
+ (while (re-search-forward "\n\n* *" nil t)
+ (replace-match "; "))
+ (if (not (zerop (buffer-size)))
+ (error "Sending...failed to %s"
+ (buffer-substring (point-min) (point-max)))))
+ (when (bufferp errbuf)
+ (kill-buffer errbuf)))))
+
+(defun message-send-mail-with-mh ()
+ "Send the prepared message buffer with mh."
+ (let ((mh-previous-window-config nil)
+ (name (make-temp-name
+ (concat (file-name-as-directory message-autosave-directory)
+ "msg."))))
+ (setq buffer-file-name name)
+ (mh-send-letter)
+ (condition-case ()
+ (delete-file name)
+ (error nil))))
+
+(defun message-send-news (&optional arg)
+ (let ((tembuf (generate-new-buffer " *message temp*"))
+ (case-fold-search nil)
+ (method (if (message-functionp message-post-method)
+ (funcall message-post-method arg)
+ message-post-method))
+ (messbuf (current-buffer))
+ (message-syntax-checks
+ (if arg
+ (cons '(existing-newsgroups . disabled)
+ message-syntax-checks)
+ message-syntax-checks))
+ result)
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Insert some headers.
+ (message-generate-headers message-required-news-headers)
+ ;; Let the user do all of the above.
+ (run-hooks 'message-header-hook))
+ (message-cleanup-headers)
+ (when (message-check-news-syntax)
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-buffer-substring messbuf)
+ ;; Remove some headers.
+ (save-restriction
+ (message-narrow-to-headers)
+ ;; Remove some headers.
+ (message-remove-header message-ignored-news-headers t))
+ (goto-char (point-max))
+ ;; require one newline at the end.
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ (let ((case-fold-search t))
+ ;; Remove the delimeter.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n"))
+ (replace-match "\n")
+ (backward-char 1))
+ (require (car method))
+ (funcall (intern (format "%s-open-server" (car method)))
+ (cadr method) (cddr method))
+ (setq result
+ (funcall (intern (format "%s-request-post" (car method))))))
+ (kill-buffer tembuf))
+ (set-buffer messbuf)
+ (if result
+ (push 'news message-sent-message-via)
+ (message "Couldn't send message via news: %s"
+ (nnheader-get-report (car method)))
+ nil))))
+
+;;;
+;;; Header generation & syntax checking.
+;;;
+
+(defun message-check-news-syntax ()
+ "Check the syntax of the message."
+ (and
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (and
+ ;; Check for commands in Subject.
+ (or
+ (message-check-element 'subject-cmsg)
+ (save-excursion
+ (if (string-match "^cmsg " (message-fetch-field "subject"))
+ (y-or-n-p
+ "The control code \"cmsg \" is in the subject. Really post? ")
+ t)))
+ ;; Check for multiple identical headers.
+ (or (message-check-element 'multiple-headers)
+ (save-excursion
+ (let (found)
+ (while (and (not found)
+ (re-search-forward "^[^ \t:]+: " nil t))
+ (save-excursion
+ (or (re-search-forward
+ (concat "^" (setq found
+ (buffer-substring
+ (match-beginning 0)
+ (- (match-end 0) 2))))
+ nil t)
+ (setq found nil))))
+ (if found
+ (y-or-n-p
+ (format "Multiple %s headers. Really post? " found))
+ t))))
+ ;; Check for Version and Sendsys.
+ (or (message-check-element 'sendsys)
+ (save-excursion
+ (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
+ (y-or-n-p
+ (format "The article contains a %s command. Really post? "
+ (buffer-substring (match-beginning 0)
+ (1- (match-end 0)))))
+ t)))
+ ;; See whether we can shorten Followup-To.
+ (or (message-check-element 'shorten-followup-to)
+ (let ((newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
+ to)
+ (when (and newsgroups (string-match "," newsgroups)
+ (not followup-to)
+ (not
+ (zerop
+ (length
+ (setq to (completing-read
+ "Followups to: (default all groups) "
+ (mapcar (lambda (g) (list g))
+ (cons "poster"
+ (message-tokenize-header
+ newsgroups)))))))))
+ (goto-char (point-min))
+ (insert "Followup-To: " to "\n"))
+ t))
+ ;; Check "Shoot me".
+ (or (message-check-element 'shoot)
+ (save-excursion
+ (if (search-forward
+ ".i-have-a-misconfigured-system-so-shoot-me" nil t)
+ (y-or-n-p
+ "You appear to have a misconfigured system. Really post? ")
+ t)))
+ ;; Check for Approved.
+ (or (message-check-element 'approved)
+ (save-excursion
+ (if (re-search-forward "^Approved:" nil t)
+ (y-or-n-p
+ "The article contains an Approved header. Really post? ")
+ t)))
+ ;; Check the Message-Id header.
+ (or (message-check-element 'message-id)
+ (save-excursion
+ (let* ((case-fold-search t)
+ (message-id (message-fetch-field "message-id")))
+ (or (not message-id)
+ (and (string-match "@" message-id)
+ (string-match "@[^\\.]*\\." message-id))
+ (y-or-n-p
+ (format
+ "The Message-ID looks strange: \"%s\". Really post? "
+ message-id))))))
+ ;; Check the Subject header.
+ (or
+ (message-check-element 'subject)
+ (save-excursion
+ (let* ((case-fold-search t)
+ (subject (message-fetch-field "subject")))
+ (or
+ (and subject
+ (not (string-match "\\`[ \t]*\\'" subject)))
+ (progn
+ (message
+ "The subject field is empty or missing. Posting is denied.")
+ nil)))))
+ ;; Check the Newsgroups & Followup-To headers.
+ (or
+ (message-check-element 'existing-newsgroups)
+ (let* ((case-fold-search t)
+ (newsgroups (message-fetch-field "newsgroups"))
+ (followup-to (message-fetch-field "followup-to"))
+ (groups (message-tokenize-header
+ (if followup-to
+ (concat newsgroups "," followup-to)
+ newsgroups)))
+ (hashtb (and (boundp 'gnus-active-hashtb)
+ gnus-active-hashtb))
+ errors)
+ (if (not hashtb)
+ t
+ (while groups
+ (when (and (not (boundp (intern (car groups) hashtb)))
+ (not (equal (car groups) "poster")))
+ (push (car groups) errors))
+ (pop groups))
+ (if (not errors)
+ t
+ (y-or-n-p
+ (format
+ "Really post to %s unknown group%s: %s "
+ (if (= (length errors) 1) "this" "these")
+ (if (= (length errors) 1) "" "s")
+ (mapconcat 'identity errors ", ")))))))
+ ;; Check the Newsgroups & Followup-To headers for syntax errors.
+ (or
+ (message-check-element 'valid-newsgroups)
+ (let ((case-fold-search t)
+ (headers '("Newsgroups" "Followup-To"))
+ header error)
+ (while (and headers (not error))
+ (when (setq header (mail-fetch-field (car headers)))
+ (if (or
+ (not
+ (string-match
+ "\\`\\([-+_&.a-zA-Z0-9]+\\)?\\(,[-.a-zA-Z0-9]+\\)*\\'"
+ header))
+ (memq
+ nil (mapcar
+ (lambda (g)
+ (not (string-match "\\.\\'\\|\\.\\." g)))
+ (message-tokenize-header header ","))))
+ (setq error t)))
+ (unless error
+ (pop headers)))
+ (if (not error)
+ t
+ (y-or-n-p
+ (format "The %s header looks odd: \"%s\". Really post? "
+ (car headers) header)))))
+ ;; Check the From header.
+ (or
+ (save-excursion
+ (let* ((case-fold-search t)
+ (from (message-fetch-field "from")))
+ (cond
+ ((not from)
+ (message "There is no From line. Posting is denied.")
+ nil)
+ ((not (string-match "@[^\\.]*\\." from))
+ (message
+ "Denied posting -- the From looks strange: \"%s\"." from)
+ nil)
+ ((string-match "@[^@]*@" from)
+ (message
+ "Denied posting -- two \"@\"'s in the From header: %s." from)
+ nil)
+ ((string-match "(.*).*(.*)" from)
+ (message
+ "Denied posting -- the From header looks strange: \"%s\"."
+ from)
+ nil)
+ (t t))))))))
+ ;; Check for long lines.
+ (or (message-check-element 'long-lines)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (while (and
+ (progn
+ (end-of-line)
+ (< (current-column) 80))
+ (zerop (forward-line 1))))
+ (or (bolp)
+ (eobp)
+ (y-or-n-p
+ "You have lines longer than 79 characters. Really post? "))))
+ ;; Check whether the article is empty.
+ (or (message-check-element 'empty)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (let ((b (point)))
+ (or (re-search-forward message-signature-separator nil t)
+ (goto-char (point-max)))
+ (beginning-of-line)
+ (or (re-search-backward "[^ \n\t]" b t)
+ (y-or-n-p "Empty article. Really post? ")))))
+ ;; Check for control characters.
+ (or (message-check-element 'control-chars)
+ (save-excursion
+ (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (y-or-n-p
+ "The article contains control characters. Really post? ")
+ t)))
+ ;; Check excessive size.
+ (or (message-check-element 'size)
+ (if (> (buffer-size) 60000)
+ (y-or-n-p
+ (format "The article is %d octets long. Really post? "
+ (buffer-size)))
+ t))
+ ;; Check whether any new text has been added.
+ (or (message-check-element 'new-text)
+ (not message-checksum)
+ (not (and (eq (message-checksum) (car message-checksum))
+ (eq (buffer-size) (cdr message-checksum))))
+ (y-or-n-p
+ "It looks like no new text has been added. Really post? "))
+ ;; Check the length of the signature.
+ (or
+ (message-check-element 'signature)
+ (progn
+ (goto-char (point-max))
+ (if (or (not (re-search-backward "^-- $" nil t))
+ (search-forward message-forward-end-separator nil t))
+ t
+ (if (> (count-lines (point) (point-max)) 5)
+ (y-or-n-p
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (count-lines (point) (point-max))))
+ t))))))
+
+(defun message-check-element (type)
+ "Returns non-nil if this type is not to be checked."
+ (if (eq message-syntax-checks 'dont-check-for-anything-just-trust-me)
+ t
+ (let ((able (assq type message-syntax-checks)))
+ (and (consp able)
+ (eq (cdr able) 'disabled)))))
+
+(defun message-checksum ()
+ "Return a \"checksum\" for the current buffer."
+ (let ((sum 0))
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (while (not (eobp))
+ (when (not (looking-at "[ \t\n]"))
+ (setq sum (logxor (ash sum 1) (following-char))))
+ (forward-char 1)))
+ sum))
+
+(defun message-do-fcc ()
+ "Process Fcc headers in the current buffer."
+ (let ((case-fold-search t)
+ (buf (current-buffer))
+ list file)
+ (save-excursion
+ (set-buffer (get-buffer-create " *message temp*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-buffer-substring buf)
+ (save-restriction
+ (message-narrow-to-headers)
+ (while (setq file (message-fetch-field "fcc"))
+ (push file list)
+ (message-remove-header "fcc" nil t)))
+ (goto-char (point-min))
+ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
+ (replace-match "" t t)
+ ;; Process FCC operations.
+ (while list
+ (setq file (pop list))
+ (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
+ ;; Pipe the article to the program in question.
+ (call-process-region (point-min) (point-max) shell-file-name
+ nil nil nil shell-command-switch
+ (match-string 1 file))
+ ;; Save the article.
+ (setq file (expand-file-name file))
+ (unless (file-exists-p (file-name-directory file))
+ (make-directory (file-name-directory file) t))
+ (if (and message-fcc-handler-function
+ (not (eq message-fcc-handler-function 'rmail-output)))
+ (funcall message-fcc-handler-function file)
+ (if (and (file-readable-p file) (mail-file-babyl-p file))
+ (rmail-output file 1)
+ (let ((mail-use-rfc822 t))
+ (rmail-output file 1 t t))))))
+ (kill-buffer (current-buffer)))))
+
+(defun message-cleanup-headers ()
+ "Do various automatic cleanups of the headers."
+ ;; Remove empty lines in the header.
+ (save-restriction
+ (message-narrow-to-headers)
+ (while (re-search-forward "^[ \t]*\n" nil t)
+ (replace-match "" t t)))
+
+ ;; Correct Newsgroups and Followup-To headers: change sequence of
+ ;; spaces to comma and eliminate spaces around commas. Eliminate
+ ;; embedded line breaks.
+ (goto-char (point-min))
+ (while (re-search-forward "^\\(Newsgroups\\|Followup-To\\): +" nil t)
+ (save-restriction
+ (narrow-to-region
+ (point)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0)
+ (forward-line 1)
+ (point)))
+ (goto-char (point-min))
+ (while (re-search-forward "\n[ \t]+" nil t)
+ (replace-match " " t t)) ;No line breaks (too confusing)
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
+ (replace-match "," t t))
+ (goto-char (point-min))
+ ;; Remove trailing commas.
+ (when (re-search-forward ",+$" nil t)
+ (replace-match "" t t)))))
+
+(defun message-make-date ()
+ "Make a valid data header."
+ (let ((now (current-time)))
+ (timezone-make-date-arpa-standard
+ (current-time-string now) (current-time-zone now))))
+
+(defun message-make-message-id ()
+ "Make a unique Message-ID."
+ (concat "<" (message-unique-id)
+ (let ((psubject (save-excursion (message-fetch-field "subject"))))
+ (if (and message-reply-headers
+ (mail-header-references message-reply-headers)
+ (mail-header-subject message-reply-headers)
+ psubject
+ (mail-header-subject message-reply-headers)
+ (not (string=
+ (message-strip-subject-re
+ (mail-header-subject message-reply-headers))
+ (message-strip-subject-re psubject))))
+ "_-_" ""))
+ "@" (message-make-fqdn) ">"))
+
+(defvar message-unique-id-char nil)
+
+;; If you ever change this function, make sure the new version
+;; cannot generate IDs that the old version could.
+;; You might for example insert a "." somewhere (not next to another dot
+;; or string boundary), or modify the "fsf" string.
+(defun message-unique-id ()
+ ;; Don't use microseconds from (current-time), they may be unsupported.
+ ;; Instead we use this randomly inited counter.
+ (setq message-unique-id-char
+ (% (1+ (or message-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+ ;; (current-time) returns 16-bit ints,
+ ;; and 2^16*25 just fits into 4 digits i base 36.
+ (* 25 25)))
+ (let ((tm (current-time)))
+ (concat
+ (if (memq system-type '(ms-dos emx vax-vms))
+ (let ((user (downcase (user-login-name))))
+ (while (string-match "[^a-z0-9_]" user)
+ (aset user (match-beginning 0) ?_))
+ user)
+ (message-number-base36 (user-uid) -1))
+ (message-number-base36 (+ (car tm)
+ (lsh (% message-unique-id-char 25) 16)) 4)
+ (message-number-base36 (+ (nth 1 tm)
+ (lsh (/ message-unique-id-char 25) 16)) 4)
+ ;; Append the newsreader name, because while the generated
+ ;; ID is unique to this newsreader, other newsreaders might
+ ;; otherwise generate the same ID via another algorithm.
+ ".fsf")))
+
+(defun message-number-base36 (num len)
+ (if (if (< len 0) (<= num 0) (= len 0))
+ ""
+ (concat (message-number-base36 (/ num 36) (1- len))
+ (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+ (% num 36))))))
+
+(defun message-make-organization ()
+ "Make an Organization header."
+ (let* ((organization
+ (or (getenv "ORGANIZATION")
+ (when message-user-organization
+ (if (message-functionp message-user-organization)
+ (funcall message-user-organization)
+ message-user-organization)))))
+ (save-excursion
+ (message-set-work-buffer)
+ (cond ((stringp organization)
+ (insert organization))
+ ((and (eq t organization)
+ message-user-organization-file
+ (file-exists-p message-user-organization-file))
+ (insert-file-contents message-user-organization-file)))
+ (goto-char (point-min))
+ (while (re-search-forward "[\t\n]+" nil t)
+ (replace-match "" t t))
+ (unless (zerop (buffer-size))
+ (buffer-string)))))
+
+(defun message-make-lines ()
+ "Count the number of lines and return numeric string."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (int-to-string (count-lines (point) (point-max))))))
+
+(defun message-make-in-reply-to ()
+ "Return the In-Reply-To header for this message."
+ (when message-reply-headers
+ (let ((from (mail-header-from message-reply-headers))
+ (date (mail-header-date message-reply-headers)))
+ (when from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (concat (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of "
+ (if (or (not date) (string= date ""))
+ "(unknown date)" date)))))))
+
+(defun message-make-distribution ()
+ "Make a Distribution header."
+ (let ((orig-distribution (message-fetch-reply-field "distribution")))
+ (cond ((message-functionp message-distribution-function)
+ (funcall message-distribution-function))
+ (t orig-distribution))))
+
+(defun message-make-expires ()
+ "Return an Expires header based on `message-expires'."
+ (let ((current (current-time))
+ (future (* 1.0 message-expires 60 60 24)))
+ ;; Add the future to current.
+ (setcar current (+ (car current) (round (/ future (expt 2 16)))))
+ (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16))))
+ ;; Return the date in the future in UT.
+ (timezone-make-date-arpa-standard
+ (current-time-string current) (current-time-zone current) '(0 "UT"))))
+
+(defun message-make-path ()
+ "Return uucp path."
+ (let ((login-name (user-login-name)))
+ (cond ((null message-user-path)
+ (concat (system-name) "!" login-name))
+ ((stringp message-user-path)
+ ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com.
+ (concat message-user-path "!" login-name))
+ (t login-name))))
+
+(defun message-make-from ()
+ "Make a From header."
+ (let* ((login (message-make-address))
+ (fullname
+ (or (and (boundp 'user-full-name)
+ user-full-name)
+ (user-full-name))))
+ (when (string= fullname "&")
+ (setq fullname (user-login-name)))
+ (save-excursion
+ (message-set-work-buffer)
+ (cond
+ ((or (null message-from-style)
+ (equal fullname ""))
+ (insert login))
+ ((or (eq message-from-style 'angles)
+ (and (not (eq message-from-style 'parens))
+ ;; Use angles if no quoting is needed, or if parens would
+ ;; need quoting too.
+ (or (not (string-match "[^- !#-'*+/-9=?A-Z^-~]" fullname))
+ (let ((tmp (concat fullname nil)))
+ (while (string-match "([^()]*)" tmp)
+ (aset tmp (match-beginning 0) ?-)
+ (aset tmp (1- (match-end 0)) ?-))
+ (string-match "[\\()]" tmp)))))
+ (insert fullname)
+ (goto-char (point-min))
+ ;; Look for a character that cannot appear unquoted
+ ;; according to RFC 822.
+ (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
+ ;; Quote fullname, escaping specials.
+ (goto-char (point-min))
+ (insert "\"")
+ (while (re-search-forward "[\"\\]" nil 1)
+ (replace-match "\\\\\\&" t))
+ (insert "\""))
+ (insert " <" login ">"))
+ (t ; 'parens or default
+ (insert login " (")
+ (let ((fullname-start (point)))
+ (insert fullname)
+ (goto-char fullname-start)
+ ;; RFC 822 says \ and nonmatching parentheses
+ ;; must be escaped in comments.
+ ;; Escape every instance of ()\ ...
+ (while (re-search-forward "[()\\]" nil 1)
+ (replace-match "\\\\\\&" t))
+ ;; ... then undo escaping of matching parentheses,
+ ;; including matching nested parentheses.
+ (goto-char fullname-start)
+ (while (re-search-forward
+ "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
+ nil 1)
+ (replace-match "\\1(\\3)" t)
+ (goto-char fullname-start)))
+ (insert ")")))
+ (buffer-string))))
+
+(defun message-make-sender ()
+ "Return the \"real\" user address.
+This function tries to ignore all user modifications, and
+give as trustworthy answer as possible."
+ (concat (user-login-name) "@" (system-name)))
+
+(defun message-make-address ()
+ "Make the address of the user."
+ (or (message-user-mail-address)
+ (concat (user-login-name) "@" (message-make-domain))))
+
+(defun message-user-mail-address ()
+ "Return the pertinent part of `user-mail-address'."
+ (when user-mail-address
+ (nth 1 (mail-extract-address-components user-mail-address))))
+
+(defun message-make-fqdn ()
+ "Return user's fully qualified domain name."
+ (let ((system-name (system-name))
+ (user-mail (message-user-mail-address)))
+ (cond
+ ((string-match "[^.]\\.[^.]" system-name)
+ ;; `system-name' returned the right result.
+ system-name)
+ ;; Try `mail-host-address'.
+ ((and (boundp 'mail-host-address)
+ (stringp mail-host-address)
+ (string-match "\\." mail-host-address))
+ mail-host-address)
+ ;; We try `user-mail-address' as a backup.
+ ((and (string-match "\\." user-mail)
+ (string-match "@\\(.*\\)\\'" user-mail))
+ (match-string 1 user-mail))
+ ;; Default to this bogus thing.
+ (t
+ (concat system-name ".i-have-a-misconfigured-system-so-shoot-me")))))
+
+(defun message-make-host-name ()
+ "Return the name of the host."
+ (let ((fqdn (message-make-fqdn)))
+ (string-match "^[^.]+\\." fqdn)
+ (substring fqdn 0 (1- (match-end 0)))))
+
+(defun message-make-domain ()
+ "Return the domain name."
+ (or mail-host-address
+ (message-make-fqdn)))
+
+(defun message-generate-headers (headers)
+ "Prepare article HEADERS.
+Headers already prepared in the buffer are not modified."
+ (save-restriction
+ (message-narrow-to-headers)
+ (let* ((Date (message-make-date))
+ (Message-ID (message-make-message-id))
+ (Organization (message-make-organization))
+ (From (message-make-from))
+ (Path (message-make-path))
+ (Subject nil)
+ (Newsgroups nil)
+ (In-Reply-To (message-make-in-reply-to))
+ (To nil)
+ (Distribution (message-make-distribution))
+ (Lines (message-make-lines))
+ (X-Newsreader message-newsreader)
+ (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
+ message-mailer))
+ (Expires (message-make-expires))
+ (case-fold-search t)
+ header value elem)
+ ;; First we remove any old generated headers.
+ (let ((headers message-deletable-headers))
+ (while headers
+ (goto-char (point-min))
+ (and (re-search-forward
+ (concat "^" (symbol-name (car headers)) ": *") nil t)
+ (get-text-property (1+ (match-beginning 0)) 'message-deletable)
+ (message-delete-line))
+ (pop headers)))
+ ;; Go through all the required headers and see if they are in the
+ ;; articles already. If they are not, or are empty, they are
+ ;; inserted automatically - except for Subject, Newsgroups and
+ ;; Distribution.
+ (while headers
+ (goto-char (point-min))
+ (setq elem (pop headers))
+ (if (consp elem)
+ (if (eq (car elem) 'optional)
+ (setq header (cdr elem))
+ (setq header (car elem)))
+ (setq header elem))
+ (when (or (not (re-search-forward
+ (concat "^" (downcase (symbol-name header)) ":")
+ nil t))
+ (progn
+ ;; The header was found. We insert a space after the
+ ;; colon, if there is none.
+ (if (/= (following-char) ? ) (insert " ") (forward-char 1))
+ ;; Find out whether the header is empty...
+ (looking-at "[ \t]*$")))
+ ;; So we find out what value we should insert.
+ (setq value
+ (cond
+ ((and (consp elem) (eq (car elem) 'optional))
+ ;; This is an optional header. If the cdr of this
+ ;; is something that is nil, then we do not insert
+ ;; this header.
+ (setq header (cdr elem))
+ (or (and (fboundp (cdr elem)) (funcall (cdr elem)))
+ (and (boundp (cdr elem)) (symbol-value (cdr elem)))))
+ ((consp elem)
+ ;; The element is a cons. Either the cdr is a
+ ;; string to be inserted verbatim, or it is a
+ ;; function, and we insert the value returned from
+ ;; this function.
+ (or (and (stringp (cdr elem)) (cdr elem))
+ (and (fboundp (cdr elem)) (funcall (cdr elem)))))
+ ((and (boundp header) (symbol-value header))
+ ;; The element is a symbol. We insert the value
+ ;; of this symbol, if any.
+ (symbol-value header))
+ (t
+ ;; We couldn't generate a value for this header,
+ ;; so we just ask the user.
+ (read-from-minibuffer
+ (format "Empty header for %s; enter value: " header)))))
+ ;; Finally insert the header.
+ (when (and value
+ (not (equal value "")))
+ (save-excursion
+ (if (bolp)
+ (progn
+ ;; This header didn't exist, so we insert it.
+ (goto-char (point-max))
+ (insert (symbol-name header) ": " value "\n")
+ (forward-line -1))
+ ;; The value of this header was empty, so we clear
+ ;; totally and insert the new value.
+ (delete-region (point) (message-point-at-eol))
+ (insert value))
+ ;; Add the deletable property to the headers that require it.
+ (and (memq header message-deletable-headers)
+ (progn (beginning-of-line) (looking-at "[^:]+: "))
+ (add-text-properties
+ (point) (match-end 0)
+ '(message-deletable t face italic) (current-buffer)))))))
+ ;; Insert new Sender if the From is strange.
+ (let ((from (message-fetch-field "from"))
+ (sender (message-fetch-field "sender"))
+ (secure-sender (message-make-sender)))
+ (when (and from
+ (not (message-check-element 'sender))
+ (not (string=
+ (downcase
+ (cadr (mail-extract-address-components from)))
+ (downcase secure-sender)))
+ (or (null sender)
+ (not
+ (string=
+ (downcase
+ (cadr (mail-extract-address-components sender)))
+ (downcase secure-sender)))))
+ (goto-char (point-min))
+ ;; Rename any old Sender headers to Original-Sender.
+ (when (re-search-forward "^Sender:" nil t)
+ (beginning-of-line)
+ (insert "Original-")
+ (beginning-of-line))
+ (insert "Sender: " secure-sender "\n"))))))
+
+(defun message-insert-courtesy-copy ()
+ "Insert a courtesy message in mail copies of combined messages."
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (let ((newsgroups (message-fetch-field "newsgroups")))
+ (when newsgroups
+ (goto-char (point-max))
+ (insert "Posted-To: " newsgroups "\n"))))
+ (forward-line 1)
+ (insert message-courtesy-message)))
+
+;;;
+;;; Setting up a message buffer
+;;;
+
+(defun message-fill-address (header value)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (narrow-to-region (point-min) (1- (point-max)))
+ (let (quoted last)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "^,\"" (point-max))
+ (if (or (= (following-char) ?,)
+ (eobp))
+ (when (not quoted)
+ (if (and (> (current-column) 78)
+ last)
+ (progn
+ (save-excursion
+ (goto-char last)
+ (insert "\n\t"))
+ (setq last (1+ (point))))
+ (setq last (1+ (point)))))
+ (setq quoted (not quoted)))
+ (unless (eobp)
+ (forward-char 1))))
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)))
+
+(defun message-fill-header (header value)
+ (let ((begin (point))
+ (fill-column 78)
+ (fill-prefix "\t"))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (save-restriction
+ (narrow-to-region begin (point))
+ (fill-region-as-paragraph begin (point))
+ ;; Tapdance around looong Message-IDs.
+ (forward-line -1)
+ (when (looking-at "[ \t]*$")
+ (message-delete-line))
+ (goto-char begin)
+ (re-search-forward ":" nil t)
+ (when (looking-at "\n[ \t]+")
+ (replace-match " " t t))
+ (goto-char (point-max)))))
+
+(defun message-position-point ()
+ "Move point to where the user probably wants to find it."
+ (message-narrow-to-headers)
+ (cond
+ ((re-search-forward "^[^:]+:[ \t]*$" nil t)
+ (search-backward ":" )
+ (widen)
+ (forward-char 1)
+ (if (= (following-char) ? )
+ (forward-char 1)
+ (insert " ")))
+ (t
+ (goto-char (point-max))
+ (widen)
+ (forward-line 1)
+ (unless (looking-at "$")
+ (forward-line 2)))
+ (sit-for 0)))
+
+(defun message-buffer-name (type &optional to group)
+ "Return a new (unique) buffer name based on TYPE and TO."
+ (cond
+ ;; Check whether `message-generate-new-buffers' is a function,
+ ;; and if so, call it.
+ ((message-functionp message-generate-new-buffers)
+ (funcall message-generate-new-buffers type to group))
+ ;; Generate a new buffer name The Message Way.
+ (message-generate-new-buffers
+ (generate-new-buffer-name
+ (concat "*" type
+ (if to
+ (concat " to "
+ (or (car (mail-extract-address-components to))
+ to) "")
+ "")
+ (if (and group (not (string= group ""))) (concat " on " group) "")
+ "*")))
+ ;; Use standard name.
+ (t
+ (format "*%s message*" type))))
+
+(defun message-pop-to-buffer (name)
+ "Pop to buffer NAME, and warn if it already exists and is modified."
+ (let ((buffer (get-buffer name)))
+ (if (and buffer
+ (buffer-name buffer))
+ (progn
+ (set-buffer (pop-to-buffer buffer))
+ (when (and (buffer-modified-p)
+ (not (y-or-n-p
+ "Message already being composed; erase? ")))
+ (error "Message being composed")))
+ (set-buffer (pop-to-buffer name))))
+ (erase-buffer)
+ (message-mode))
+
+(defun message-do-send-housekeeping ()
+ "Kill old message buffers."
+ ;; We might have sent this buffer already. Delete it from the
+ ;; list of buffers.
+ (setq message-buffer-list (delq (current-buffer) message-buffer-list))
+ (when (and message-max-buffers
+ (>= (length message-buffer-list) message-max-buffers))
+ ;; Kill the oldest buffer -- unless it has been changed.
+ (let ((buffer (pop message-buffer-list)))
+ (when (and (buffer-name buffer)
+ (not (buffer-modified-p buffer)))
+ (kill-buffer buffer))))
+ ;; Rename the buffer.
+ (if message-send-rename-function
+ (funcall message-send-rename-function)
+ (when (string-match "\\`\\*" (buffer-name))
+ (rename-buffer
+ (concat "*sent " (substring (buffer-name) (match-end 0))) t)))
+ ;; Push the current buffer onto the list.
+ (when message-max-buffers
+ (setq message-buffer-list
+ (nconc message-buffer-list (list (current-buffer))))))
+
+(defvar mc-modes-alist)
+(defun message-setup (headers &optional replybuffer actions)
+ (when (and (boundp 'mc-modes-alist)
+ (not (assq 'message-mode mc-modes-alist)))
+ (push '(message-mode (encrypt . mc-encrypt-message)
+ (sign . mc-sign-message))
+ mc-modes-alist))
+ (when actions
+ (setq message-send-actions actions))
+ (setq message-reply-buffer replybuffer)
+ (goto-char (point-min))
+ ;; Insert all the headers.
+ (mail-header-format
+ (let ((h headers)
+ (alist message-header-format-alist))
+ (while h
+ (unless (assq (caar h) message-header-format-alist)
+ (push (list (caar h)) alist))
+ (pop h))
+ alist)
+ headers)
+ (delete-region (point) (progn (forward-line -1) (point)))
+ (when message-default-headers
+ (insert message-default-headers))
+ (put-text-property
+ (point)
+ (progn
+ (insert mail-header-separator "\n")
+ (1- (point)))
+ 'read-only nil)
+ (forward-line -1)
+ (when (message-news-p)
+ (when message-default-news-headers
+ (insert message-default-news-headers))
+ (when message-generate-headers-first
+ (message-generate-headers
+ (delq 'Lines
+ (delq 'Subject
+ (copy-sequence message-required-news-headers))))))
+ (when (message-mail-p)
+ (when message-default-mail-headers
+ (insert message-default-mail-headers))
+ (when message-generate-headers-first
+ (message-generate-headers
+ (delq 'Lines
+ (delq 'Subject
+ (copy-sequence message-required-mail-headers))))))
+ (run-hooks 'message-signature-setup-hook)
+ (message-insert-signature)
+ (message-set-auto-save-file-name)
+ (save-restriction
+ (message-narrow-to-headers)
+ (run-hooks 'message-header-setup-hook))
+ (set-buffer-modified-p nil)
+ (run-hooks 'message-setup-hook)
+ (message-position-point)
+ (undo-boundary))
+
+(defun message-set-auto-save-file-name ()
+ "Associate the message buffer with a file in the drafts directory."
+ (when message-autosave-directory
+ (unless (file-exists-p message-autosave-directory)
+ (make-directory message-autosave-directory t))
+ (let ((name (make-temp-name
+ (concat (file-name-as-directory message-autosave-directory)
+ "msg."))))
+ (setq buffer-auto-save-file-name
+ (save-excursion
+ (prog1
+ (progn
+ (set-buffer (get-buffer-create " *draft tmp*"))
+ (setq buffer-file-name name)
+ (make-auto-save-file-name))
+ (kill-buffer (current-buffer)))))
+ (clear-visited-file-modtime))))
+
+\f
+
+;;;
+;;; Commands for interfacing with message
+;;;
+
+;;;###autoload
+(defun message-mail (&optional to subject)
+ "Start editing a mail message to be sent."
+ (interactive)
+ (message-pop-to-buffer (message-buffer-name "mail" to))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-news (&optional newsgroups subject)
+ "Start editing a news article to be sent."
+ (interactive)
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-reply (&optional to-address wide ignore-reply-to)
+ "Start editing a reply to the article in the current buffer."
+ (interactive)
+ (let ((cur (current-buffer))
+ from subject date reply-to to cc
+ references message-id follow-to
+ mct never-mct gnus-warning)
+ (save-restriction
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ ;; Allow customizations to have their say.
+ (if (not wide)
+ ;; This is a regular reply.
+ (if (message-functionp message-reply-to-function)
+ (setq follow-to (funcall message-reply-to-function)))
+ ;; This is a followup.
+ (if (message-functionp message-wide-reply-to-function)
+ (save-excursion
+ (setq follow-to
+ (funcall message-wide-reply-to-function)))))
+ ;; Find all relevant headers we need.
+ (setq from (message-fetch-field "from")
+ date (message-fetch-field "date")
+ subject (or (message-fetch-field "subject") "none")
+ to (message-fetch-field "to")
+ cc (message-fetch-field "cc")
+ mct (message-fetch-field "mail-copies-to")
+ reply-to (unless ignore-reply-to (message-fetch-field "reply-to"))
+ references (message-fetch-field "references")
+ message-id (message-fetch-field "message-id"))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond ((equal (downcase mct) "never")
+ (setq never-mct t)
+ (setq mct nil))
+ ((equal (downcase mct) "always")
+ (setq mct (or reply-to from)))))
+
+ (unless follow-to
+ (if (or (not wide)
+ to-address)
+ (setq follow-to (list (cons 'To (or to-address reply-to from))))
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (unless never-mct
+ (insert (or reply-to from "")))
+ (insert
+ (if (bolp) "" ", ") (or to "")
+ (if mct (concat (if (bolp) "" ", ") mct) "")
+ (if cc (concat (if (bolp) "" ", ") cc) ""))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer)))
+ (goto-char (point-min))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (nreverse (mail-parse-comma-list))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (push (cons 'Cc
+ (mapconcat (lambda (addr) (cdr addr)) ccalist ", "))
+ follow-to)))))
+ (widen))
+
+ (message-pop-to-buffer (message-buffer-name "reply" from))
+
+ (setq message-reply-headers
+ (vector 0 subject from date message-id references 0 0 ""))
+
+ (message-setup
+ `((Subject . ,subject)
+ ,@follow-to
+ ,@(if (or references message-id)
+ `((References . ,(concat (or references "") (and references " ")
+ (or message-id ""))))
+ nil))
+ cur)))
+
+;;;###autoload
+(defun message-wide-reply (&optional to-address)
+ (interactive)
+ (message-reply to-address t))
+
+;;;###autoload
+(defun message-followup ()
+ (interactive)
+ (let ((cur (current-buffer))
+ from subject date reply-to mct
+ references message-id follow-to
+ followup-to distribution newsgroups gnus-warning)
+ (save-restriction
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ (when (message-functionp message-followup-to-function)
+ (setq follow-to
+ (funcall message-followup-to-function)))
+ (setq from (message-fetch-field "from")
+ date (message-fetch-field "date")
+ subject (or (message-fetch-field "subject") "none")
+ references (message-fetch-field "references")
+ message-id (message-fetch-field "message-id")
+ followup-to (message-fetch-field "followup-to")
+ newsgroups (message-fetch-field "newsgroups")
+ reply-to (message-fetch-field "reply-to")
+ distribution (message-fetch-field "distribution")
+ mct (message-fetch-field "mail-copies-to"))
+ (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
+ (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
+ ;; Remove bogus distribution.
+ (and (stringp distribution)
+ (string-match "world" distribution)
+ (setq distribution nil))
+ ;; Remove any (buggy) Re:'s that are present and make a
+ ;; proper one.
+ (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
+ (setq subject (substring subject (match-end 0))))
+ (setq subject (concat "Re: " subject))
+ (widen))
+
+ (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
+
+ (message-setup
+ `((Subject . ,subject)
+ ,@(cond
+ (follow-to follow-to)
+ ((and followup-to message-use-followup-to)
+ (list
+ (cond
+ ((equal (downcase followup-to) "poster")
+ (if (or (eq message-use-followup-to 'use)
+ (message-y-or-n-p "Obey Followup-To: poster? " t "\
+You should normally obey the Followup-To: header.
+
+`Followup-To: poster' sends your response via e-mail instead of news.
+
+A typical situation where `Followup-To: poster' is used is when the poster
+does not read the newsgroup, so he wouldn't see any replies sent to it."))
+ (cons 'To (or reply-to from ""))
+ (cons 'Newsgroups newsgroups)))
+ (t
+ (if (or (equal followup-to newsgroups)
+ (not (eq message-use-followup-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Followup-To: " followup-to "? ") t "\
+You should normally obey the Followup-To: header.
+
+ `Followup-To: " followup-to "'
+directs your response to " (if (string-match "," followup-to)
+ "the specified newsgroups"
+ "that newsgroup only") ".
+
+If a message is posted to several newsgroups, Followup-To is often
+used to direct the following discussion to one newsgroup only,
+because discussions that are spread over several newsgroup tend to
+be fragmented and very difficult to follow.
+
+Also, some source/announcment newsgroups are not indented for discussion;
+responses here are directed to other newsgroups."))
+ (cons 'Newsgroups followup-to)
+ (cons 'Newsgroups newsgroups))))))
+ (t
+ `((Newsgroups . ,newsgroups))))
+ ,@(and distribution (list (cons 'Distribution distribution)))
+ (References . ,(concat (or references "") (and references " ")
+ (or message-id "")))
+ ,@(when (and mct
+ (not (equal (downcase mct) "never")))
+ (list (cons 'Cc (if (equal (downcase mct) "always")
+ (or reply-to from "")
+ mct)))))
+
+ cur)
+
+ (setq message-reply-headers
+ (vector 0 subject from date message-id references 0 0 ""))))
+
+
+;;;###autoload
+(defun message-cancel-news ()
+ "Cancel an article you posted."
+ (interactive)
+ (unless (message-news-p)
+ (error "This is not a news article; canceling is impossible"))
+ (when (yes-or-no-p "Do you really want to cancel this article? ")
+ (let (from newsgroups message-id distribution buf)
+ (save-excursion
+ ;; Get header info. from original article.
+ (save-restriction
+ (message-narrow-to-head)
+ (setq from (message-fetch-field "from")
+ newsgroups (message-fetch-field "newsgroups")
+ message-id (message-fetch-field "message-id")
+ distribution (message-fetch-field "distribution")))
+ ;; Make sure that this article was written by the user.
+ (unless (string-equal
+ (downcase (cadr (mail-extract-address-components from)))
+ (downcase (message-make-address)))
+ (error "This article is not yours"))
+ ;; Make control message.
+ (setq buf (set-buffer (get-buffer-create " *message cancel*")))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert "Newsgroups: " newsgroups "\n"
+ "From: " (message-make-from) "\n"
+ "Subject: cmsg cancel " message-id "\n"
+ "Control: cancel " message-id "\n"
+ (if distribution
+ (concat "Distribution: " distribution "\n")
+ "")
+ mail-header-separator "\n"
+ "This is a cancel message from " from ".\n")
+ (message "Canceling your article...")
+ (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me))
+ (funcall message-send-news-function))
+ (message "Canceling your article...done")
+ (kill-buffer buf)))))
+
+;;;###autoload
+(defun message-supersede ()
+ "Start composing a message to supersede the current message.
+This is done simply by taking the old article and adding a Supersedes
+header line with the old Message-ID."
+ (interactive)
+ (let ((cur (current-buffer)))
+ ;; Check whether the user owns the article that is to be superseded.
+ (unless (string-equal
+ (downcase (cadr (mail-extract-address-components
+ (message-fetch-field "from"))))
+ (downcase (message-make-address)))
+ (error "This article is not yours"))
+ ;; Get a normal message buffer.
+ (message-pop-to-buffer (message-buffer-name "supersede"))
+ (insert-buffer-substring cur)
+ (message-narrow-to-head)
+ ;; Remove unwanted headers.
+ (when message-ignored-supersedes-headers
+ (message-remove-header message-ignored-supersedes-headers t))
+ (goto-char (point-min))
+ (if (not (re-search-forward "^Message-ID: " nil t))
+ (error "No Message-ID in this article")
+ (replace-match "Supersedes: " t t))
+ (goto-char (point-max))
+ (insert mail-header-separator)
+ (widen)
+ (forward-line 1)))
+
+;;;###autoload
+(defun message-recover ()
+ "Reread contents of current buffer from its last auto-save file."
+ (interactive)
+ (let ((file-name (make-auto-save-file-name)))
+ (cond ((save-window-excursion
+ (if (not (eq system-type 'vax-vms))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-disable-undo standard-output)
+ (let ((default-directory "/"))
+ (call-process
+ "ls" nil standard-output nil "-l" file-name))))
+ (yes-or-no-p (format "Recover auto save file %s? " file-name)))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert-file-contents file-name nil)))
+ (t (error "message-recover cancelled")))))
+
+;;; Forwarding messages.
+
+(defun message-make-forward-subject ()
+ "Return a Subject header suitable for the message in the current buffer."
+ (concat "[" (or (message-fetch-field (if (message-news-p) "newsgroups" "from"))
+ "(nowhere)")
+ "] " (or (message-fetch-field "Subject") "")))
+
+;;;###autoload
+(defun message-forward (&optional news)
+ "Forward the current message via mail.
+Optional NEWS will use news to forward instead of mail."
+ (interactive "P")
+ (let ((cur (current-buffer))
+ (subject (message-make-forward-subject)))
+ (if news (message-news nil subject) (message-mail nil subject))
+ ;; Put point where we want it before inserting the forwarded
+ ;; message.
+ (if message-signature-before-forwarded-message
+ (goto-char (point-max))
+ (message-goto-body))
+ ;; Make sure we're at the start of the line.
+ (unless (eolp)
+ (insert "\n"))
+ ;; Narrow to the area we are to insert.
+ (narrow-to-region (point) (point))
+ ;; Insert the separators and the forwarded buffer.
+ (insert message-forward-start-separator)
+ (insert-buffer-substring cur)
+ (goto-char (point-max))
+ (insert message-forward-end-separator)
+ (set-text-properties (point-min) (point-max) nil)
+ ;; Remove all unwanted headers.
+ (goto-char (point-min))
+ (forward-line 1)
+ (narrow-to-region (point) (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point)))
+ (goto-char (point-min))
+ (message-remove-header message-included-forward-headers t nil t)
+ (widen)
+ (message-position-point)))
+
+;;;###autoload
+(defun message-resend (address)
+ "Resend the current article to ADDRESS."
+ (interactive "sResend message to: ")
+ (save-excursion
+ (let ((cur (current-buffer))
+ beg)
+ ;; We first set up a normal mail buffer.
+ (set-buffer (get-buffer-create " *message resend*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (message-setup `((To . ,address)))
+ ;; Insert our usual headers.
+ (message-generate-headers '(From Date To))
+ (message-narrow-to-headers)
+ ;; Rename them all to "Resent-*".
+ (while (re-search-forward "^[A-Za-z]" nil t)
+ (forward-char -1)
+ (insert "Resent-"))
+ (widen)
+ (forward-line)
+ (delete-region (point) (point-max))
+ (setq beg (point))
+ ;; Insert the message to be resent.
+ (insert-buffer-substring cur)
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (forward-char -1)
+ (save-restriction
+ (narrow-to-region beg (point))
+ (message-remove-header message-ignored-resent-headers t)
+ (goto-char (point-max)))
+ (insert mail-header-separator)
+ ;; Rename all old ("Also-")Resent headers.
+ (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
+ (beginning-of-line)
+ (insert "Also-"))
+ ;; Send it.
+ (message-send-mail)
+ (kill-buffer (current-buffer)))))
+
+;;;###autoload
+(defun message-bounce ()
+ "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."
+ (interactive)
+ (let ((cur (current-buffer))
+ boundary)
+ (message-pop-to-buffer (message-buffer-name "bounce"))
+ (insert-buffer-substring cur)
+ (undo-boundary)
+ (message-narrow-to-head)
+ (if (and (message-fetch-field "Mime-Version")
+ (setq boundary (message-fetch-field "Content-Type")))
+ (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
+ (setq boundary (concat (match-string 1 boundary) " *\n"
+ "Content-Type: message/rfc822"))
+ (setq boundary nil)))
+ (widen)
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (or (and boundary
+ (re-search-forward boundary nil t)
+ (forward-line 2))
+ (and (re-search-forward message-unsent-separator nil t)
+ (forward-line 1))
+ (and (search-forward "\n\n" nil t)
+ (re-search-forward "^Return-Path:.*\n" nil t)))
+ ;; We remove everything before the bounced mail.
+ (delete-region
+ (point-min)
+ (if (re-search-forward "^[^ \n\t]+:" nil t)
+ (match-beginning 0)
+ (point)))
+ (save-restriction
+ (message-narrow-to-head)
+ (message-remove-header message-ignored-bounced-headers t)
+ (goto-char (point-max))
+ (insert mail-header-separator))
+ (message-position-point)))
+
+;;;
+;;; Interactive entry points for new message buffers.
+;;;
+
+;;;###autoload
+(defun message-mail-other-window (&optional to subject)
+ "Like `message-mail' command, but display mail buffer in another window."
+ (interactive)
+ (let ((pop-up-windows t)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-mail-other-frame (&optional to subject)
+ "Like `message-mail' command, but display mail buffer in another frame."
+ (interactive)
+ (let ((pop-up-frames t)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (message-pop-to-buffer (message-buffer-name "mail" to)))
+ (message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-news-other-window (&optional newsgroups subject)
+ "Start editing a news article to be sent."
+ (interactive)
+ (let ((pop-up-windows t)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject "")))))
+
+;;;###autoload
+(defun message-news-other-frame (&optional newsgroups subject)
+ "Start editing a news article to be sent."
+ (interactive)
+ (let ((pop-up-frames t)
+ (special-display-buffer-names nil)
+ (special-display-regexps nil)
+ (same-window-buffer-names nil)
+ (same-window-regexps nil))
+ (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))
+ (message-setup `((Newsgroups . ,(or newsgroups ""))
+ (Subject . ,(or subject "")))))
+
+;;; underline.el
+
+;; This code should be moved to underline.el (from which it is stolen).
+
+;;;###autoload
+(defun bold-region (start end)
+ "Bold all nonblank characters in the region.
+Works by overstriking characters.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ (interactive "r")
+ (save-excursion
+ (let ((end1 (make-marker)))
+ (move-marker end1 (max start end))
+ (goto-char (min start end))
+ (while (< (point) end1)
+ (or (looking-at "[_\^@- ]")
+ (insert (following-char) "\b"))
+ (forward-char 1)))))
+
+;;;###autoload
+(defun unbold-region (start end)
+ "Remove all boldness (overstruck characters) in the region.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ (interactive "r")
+ (save-excursion
+ (let ((end1 (make-marker)))
+ (move-marker end1 (max start end))
+ (goto-char (min start end))
+ (while (re-search-forward "\b" end1 t)
+ (if (eq (following-char) (char-after (- (point) 2)))
+ (delete-char -2))))))
+
+(fset 'message-exchange-point-and-mark 'exchange-point-and-mark)
+
+;; Support for toolbar
+(when (string-match "XEmacs\\|Lucid" emacs-version)
+ (require 'messagexmas))
+
+;;; Group name completion.
+
+(defvar message-newgroups-header-regexp
+ "^\\(Newsgroups\\|Followup-To\\|Posted-To\\):"
+ "Regexp that match headers that lists groups.")
+
+(defun message-tab ()
+ "Expand group names in Newsgroups and Followup-To headers.
+Do a `tab-to-tab-stop' if not in those headers."
+ (interactive)
+ (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))
+ (mail-abbrev-in-expansion-header-p))
+ (message-expand-group)
+ (tab-to-tab-stop)))
+
+(defvar gnus-active-hashtb)
+(defun message-expand-group ()
+ (let* ((b (save-excursion (skip-chars-backward "^, :\t\n") (point)))
+ (completion-ignore-case t)
+ (string (buffer-substring b (point)))
+ (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
+ (completions (all-completions string hashtb))
+ (cur (current-buffer))
+ comp)
+ (delete-region b (point))
+ (cond
+ ((= (length completions) 1)
+ (if (string= (car completions) string)
+ (progn
+ (insert string)
+ (message "Only matching group"))
+ (insert (car completions))))
+ ((and (setq comp (try-completion string hashtb))
+ (not (string= comp string)))
+ (insert comp))
+ (t
+ (insert string)
+ (if (not comp)
+ (message "No matching groups")
+ (pop-to-buffer "*Completions*")
+ (buffer-disable-undo (current-buffer))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (display-completion-list (sort completions 'string<)))
+ (goto-char (point-min))
+ (pop-to-buffer cur)))))))
+
+;;; Help stuff.
+
+(defmacro message-y-or-n-p (question show &rest text)
+ "Ask QUESTION, displaying the rest of the arguments in a temporary buffer."
+ `(message-talkative-question 'y-or-n-p ,question ,show ,@text))
+
+(defun message-talkative-question (ask question show &rest text)
+ "Call FUNCTION with argument QUESTION, displaying the rest of the arguments in a temporary buffer if SHOW.
+The following arguments may contain lists of values."
+ (if (and show
+ (setq text (message-flatten-list text)))
+ (save-window-excursion
+ (save-excursion
+ (with-output-to-temp-buffer " *MESSAGE information message*"
+ (set-buffer " *MESSAGE information message*")
+ (mapcar 'princ text)
+ (goto-char (point-min))))
+ (funcall ask question))
+ (funcall ask question)))
+
+(defun message-flatten-list (&rest list)
+ (message-flatten-list-1 list))
+
+(defun message-flatten-list-1 (list)
+ (cond ((consp list)
+ (apply 'append (mapcar 'message-flatten-list-1 list)))
+ (list
+ (list list))))
+
+(run-hooks 'message-load-hook)
+
+(provide 'message)
+
+;;; message.el ends here
--- /dev/null
+;;; 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)
+
+\f
+
+(defconst nndb-version "nndb 0.3"
+ "Version numbers of this version of NNDB.")
+
+\f
+;;; 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)
+
+
--- /dev/null
+;;; 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.
--- /dev/null
+;;; 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.
--- /dev/null
+;;; 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'.")
+
+\f
+
+(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)
+
+\f
+
+;;; 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))
+
+\f
+;;; 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
projects / emacs.git / commitdiff