Mercurial > emacs
changeset 15512:47d9b7a1dee3
Initial revision
| author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
|---|---|
| date | Tue, 25 Jun 1996 22:35:26 +0000 |
| parents | 530d0d516a42 |
| children | 1252826f389b |
| files | lisp/gnus-demon.el lisp/gnus-gl.el lisp/gnus-nocem.el lisp/gnus-salt.el lisp/gnus-scomo.el lisp/gnus-setup.el lisp/gnus-soup.el lisp/gnus-srvr.el lisp/gnus-topic.el lisp/mail/mailheader.el lisp/message.el lisp/nndb.el lisp/nnheaderems.el lisp/nnoo.el lisp/nnsoup.el |
| diffstat | 15 files changed, 9249 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-demon.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,222 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-gl.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,872 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-nocem.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,246 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-salt.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,654 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-scomo.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,110 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-setup.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,210 @@ +;;; gnus-setup.el --- Initialization & Setup for Gnus 5 +;; Copyright (C) 1995, 96 Free Software Foundation, Inc. + +;; Author: Steven L. Baur <steve@miranova.com> +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; My head is starting to spin with all the different mail/news packages. +;; Stop The Madness! + +;; Given that Emacs Lisp byte codes may be diverging, it is probably best +;; not to byte compile this, and just arrange to have the .el loaded out +;; of .emacs. + +;;; Code: + +(defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)) + +(defvar gnus-emacs-lisp-directory (if running-xemacs + "/usr/local/lib/xemacs/" + "/usr/local/share/emacs/") + "Directory where Emacs site lisp is located.") + +(defvar gnus-gnus-lisp-directory (concat gnus-emacs-lisp-directory + "gnus-5.0.15/lisp/") + "Directory where Gnus Emacs lisp is found.") + +(defvar gnus-sgnus-lisp-directory (concat gnus-emacs-lisp-directory + "sgnus/lisp/") + "Directory where September Gnus Emacs lisp is found.") + +(defvar gnus-tm-lisp-directory (concat gnus-emacs-lisp-directory + "site-lisp/") + "Directory where TM Emacs lisp is found.") + +(defvar gnus-mailcrypt-lisp-directory (concat gnus-emacs-lisp-directory + "site-lisp/mailcrypt-3.4/") + "Directory where Mailcrypt Emacs Lisp is found.") + +(defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory + "site-lisp/bbdb-1.50/") + "Directory where Big Brother Database is found.") + +(defvar gnus-use-tm t + "Set this if you want MIME support for Gnus") +(defvar gnus-use-mhe nil + "Set this if you want to use MH-E for mail reading") +(defvar gnus-use-rmail nil + "Set this if you want to use RMAIL for mail reading") +(defvar gnus-use-sendmail t + "Set this if you want to use SENDMAIL for mail reading") +(defvar gnus-use-vm nil + "Set this if you want to use the VM package for mail reading") +(defvar gnus-use-sc t + "Set this if you want to use Supercite") +(defvar gnus-use-mailcrypt t + "Set this if you want to use Mailcrypt for dealing with PGP messages") +(defvar gnus-use-bbdb nil + "Set this if you want to use the Big Brother DataBase") +(defvar gnus-use-september nil + "Set this if you are using the experimental September Gnus") + +(let ((gnus-directory (if gnus-use-september + gnus-sgnus-lisp-directory + gnus-gnus-lisp-directory))) + (if (null (member gnus-directory load-path)) + (setq load-path (cons gnus-directory load-path)))) + +;;; Tools for MIME by +;;; UMEDA Masanobu <umerin@mse.kyutech.ac.jp> +;;; MORIOKA Tomohiko <morioka@jaist.ac.jp> + +(if gnus-use-tm + (progn + (if (null (member gnus-tm-lisp-directory load-path)) + (setq load-path (cons gnus-tm-lisp-directory load-path))) + (load "mime-setup"))) + +;;; Mailcrypt by +;;; Jin Choi <jin@atype.com> +;;; Patrick LoPresti <patl@lcs.mit.edu> + +(if gnus-use-mailcrypt + (progn + (if (null (member gnus-mailcrypt-lisp-directory load-path)) + (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) + (autoload 'mc-install-write-mode "mailcrypt" nil t) + (autoload 'mc-install-read-mode "mailcrypt" nil t) + (add-hook 'message-mode-hook 'mc-install-write-mode) + (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) + (if gnus-use-mhe + (progn + (add-hook 'mh-folder-mode-hook 'mc-install-read-mode) + (add-hook 'mh-letter-mode-hook 'mc-install-write-mode))))) + +;;; BBDB by +;;; Jamie Zawinski <jwz@lucid.com> + +(if gnus-use-bbdb + (progn + (if (null (member gnus-bbdb-lisp-directory load-path)) + (setq load-path (cons gnus-bbdb-lisp-directory load-path))) + (autoload 'bbdb "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-name "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-company "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-net "bbdb-com" + "Insidious Big Brother Database" t) + (autoload 'bbdb-notes "bbdb-com" + "Insidious Big Brother Database" t) + + (if gnus-use-vm + (progn + (autoload 'bbdb-insinuate-vm "bbdb-vm" + "Hook BBDB into VM" t))) + + (if gnus-use-rmail + (progn + (autoload 'bbdb-insinuate-rmail "bbdb-rmail" + "Hook BBDB into RMAIL" t) + (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail))) + + (if gnus-use-mhe + (progn + (autoload 'bbdb-insinuate-mh "bbdb-mh" + "Hook BBDB into MH-E" t) + (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh))) + + (autoload 'bbdb-insinuate-gnus "bbdb-gnus" + "Hook BBDB into Gnus" t) + (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) + + (if gnus-use-sendmail + (progn + (autoload 'bbdb-insinuate-sendmail "bbdb" + "Insidious Big Brother Database" t) + (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail) + (add-hook 'message-setup-hook 'bbdb-insinuate-sendmail))))) + +(if gnus-use-sc + (progn + (add-hook 'mail-citation-hook 'sc-cite-original) + (setq message-cite-function 'sc-cite-original) + (autoload 'sc-cite-original "supercite"))) + +;;;### (autoloads (gnus-batch-score gnus-fetch-group gnus gnus-slave gnus-no-server gnus-update-format) "gnus" "lisp/gnus.el" (12473 2137)) +;;; Generated autoloads from lisp/gnus.el + +(autoload 'gnus-update-format "gnus" "\ +Update the format specification near point." t nil) + +(autoload 'gnus-slave-no-server "gnus" "\ +Read network news as a slave without connecting to local server." t nil) + +(autoload 'gnus-no-server "gnus" "\ +Read network news. +If ARG is a positive number, Gnus will use that as the +startup level. If ARG is nil, Gnus will be started at level 2. +If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use. +As opposed to `gnus', this command will not connect to the local server." t nil) + +(autoload 'gnus-slave "gnus" "\ +Read news as a slave." t nil) + +(autoload 'gnus "gnus" "\ +Read network news. +If ARG is non-nil and a positive number, Gnus will use that as the +startup level. If ARG is non-nil and not a positive number, Gnus will +prompt the user for the name of an NNTP server to use." t nil) + +(autoload 'gnus-fetch-group "gnus" "\ +Start Gnus if necessary and enter GROUP. +Returns whether the fetching was successful or not." t nil) + +(defalias 'gnus-batch-kill 'gnus-batch-score) + +(autoload 'gnus-batch-score "gnus" "\ +Run batched scoring. +Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ... +Newsgroups is a list of strings in Bnews format. If you want to score +the comp hierarchy, you'd say \"comp.all\". If you would not like to +score the alt hierarchy, you'd say \"!alt.all\"." t nil) + +;;;*** + +(provide 'gnus-setup) + +(run-hooks 'gnus-setup-load-hook) + +;;; gnus-setup.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-soup.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,563 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-srvr.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,708 @@ +;;; gnus-srvr.el --- virtual server support for Gnus +;; Copyright (C) 1995,96 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'gnus) +(eval-when-compile (require 'cl)) + +(defvar gnus-server-mode-hook nil + "Hook run in `gnus-server-mode' buffers.") + +(defconst gnus-server-line-format " {%(%h:%w%)} %s\n" + "Format of server lines. +It works along the same lines as a normal formatting string, +with some simple extensions.") + +(defvar gnus-server-mode-line-format "Gnus List of servers" + "The format specification for the server mode line.") + +(defvar gnus-server-exit-hook nil + "*Hook run when exiting the server buffer.") + +;;; Internal variables. + +(defvar gnus-inserted-opened-servers nil) + +(defvar gnus-server-line-format-alist + `((?h how ?s) + (?n name ?s) + (?w where ?s) + (?s status ?s))) + +(defvar gnus-server-mode-line-format-alist + `((?S news-server ?s) + (?M news-method ?s) + (?u user-defined ?s))) + +(defvar gnus-server-line-format-spec nil) +(defvar gnus-server-mode-line-format-spec nil) +(defvar gnus-server-killed-servers nil) + +(defvar gnus-server-mode-map) + +(defvar gnus-server-menu-hook nil + "*Hook run after the creation of the server mode menu.") + +(defun gnus-server-make-menu-bar () + (gnus-visual-turn-off-edit-menu 'server) + (unless (boundp 'gnus-server-server-menu) + (easy-menu-define + gnus-server-server-menu gnus-server-mode-map "" + '("Server" + ["Add" gnus-server-add-server t] + ["Browse" gnus-server-read-server t] + ["List" gnus-server-list-servers t] + ["Kill" gnus-server-kill-server t] + ["Yank" gnus-server-yank-server t] + ["Copy" gnus-server-copy-server t] + ["Edit" gnus-server-edit-server t] + ["Exit" gnus-server-exit t] + )) + + (easy-menu-define + gnus-server-connections-menu gnus-server-mode-map "" + '("Connections" + ["Open" gnus-server-open-server t] + ["Close" gnus-server-close-server t] + ["Deny" gnus-server-deny-server t] + ["Reset" gnus-server-remove-denials t] + )) + + (run-hooks 'gnus-server-menu-hook))) + +(defvar gnus-server-mode-map nil) +(put 'gnus-server-mode 'mode-class 'special) + +(unless gnus-server-mode-map + (setq gnus-server-mode-map (make-sparse-keymap)) + (suppress-keymap gnus-server-mode-map) + + (gnus-define-keys + gnus-server-mode-map + " " gnus-server-read-server + "\r" gnus-server-read-server + gnus-mouse-2 gnus-server-pick-server + "q" gnus-server-exit + "l" gnus-server-list-servers + "k" gnus-server-kill-server + "y" gnus-server-yank-server + "c" gnus-server-copy-server + "a" gnus-server-add-server + "e" gnus-server-edit-server + + "O" gnus-server-open-server + "C" gnus-server-close-server + "D" gnus-server-deny-server + "R" gnus-server-remove-denials + + "\C-c\C-i" gnus-info-find-node)) + +(defun gnus-server-mode () + "Major mode for listing and editing servers. + +All normal editing commands are switched off. +\\<gnus-server-mode-map> +For more in-depth information on this mode, read the manual +(`\\[gnus-info-find-node]'). + +The following commands are available: + +\\{gnus-server-mode-map}" + (interactive) + (when (and menu-bar-mode + (gnus-visual-p 'server-menu 'menu)) + (gnus-server-make-menu-bar)) + (kill-all-local-variables) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-server-mode) + (setq mode-name "Server") + ; (gnus-group-set-mode-line) + (setq mode-line-process nil) + (use-local-map gnus-server-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (setq buffer-read-only t) + (run-hooks 'gnus-server-mode-hook)) + +(defun gnus-server-insert-server-line (name method) + (let* ((how (car method)) + (where (nth 1 method)) + (elem (assoc method gnus-opened-servers)) + (status (cond ((eq (nth 1 elem) 'denied) + "(denied)") + ((or (gnus-server-opened method) + (eq (nth 1 elem) 'ok)) + "(opened)") + (t + "(closed)")))) + (beginning-of-line) + (gnus-add-text-properties + (point) + (prog1 (1+ (point)) + ;; Insert the text. + (eval gnus-server-line-format-spec)) + (list 'gnus-server (intern name))))) + +(defun gnus-enter-server-buffer () + "Set up the server buffer." + (gnus-server-setup-buffer) + (gnus-configure-windows 'server) + (gnus-server-prepare)) + +(defun gnus-server-setup-buffer () + "Initialize the server buffer." + (unless (get-buffer gnus-server-buffer) + (save-excursion + (set-buffer (get-buffer-create gnus-server-buffer)) + (gnus-server-mode) + (when gnus-carpal + (gnus-carpal-setup-buffer 'server))))) + +(defun gnus-server-prepare () + (setq gnus-server-mode-line-format-spec + (gnus-parse-format gnus-server-mode-line-format + gnus-server-mode-line-format-alist)) + (setq gnus-server-line-format-spec + (gnus-parse-format gnus-server-line-format + gnus-server-line-format-alist t)) + (let ((alist gnus-server-alist) + (buffer-read-only nil) + (opened gnus-opened-servers) + done server op-ser) + (erase-buffer) + (setq gnus-inserted-opened-servers nil) + ;; First we do the real list of servers. + (while alist + (push (cdr (setq server (pop alist))) done) + (when (and server (car server) (cdr server)) + (gnus-server-insert-server-line (car server) (cdr server)))) + ;; Then we insert the list of servers that have been opened in + ;; this session. + (while opened + (unless (member (caar opened) done) + (gnus-server-insert-server-line + (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) + (caar opened)) + (push (list op-ser (caar opened)) gnus-inserted-opened-servers)) + (setq opened (cdr opened)))) + (goto-char (point-min)) + (gnus-server-position-point)) + +(defun gnus-server-server-name () + (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) + (and server (symbol-name server)))) + +(defalias 'gnus-server-position-point 'gnus-goto-colon) + +(defconst gnus-server-edit-buffer "*Gnus edit server*") + +(defun gnus-server-update-server (server) + (save-excursion + (set-buffer gnus-server-buffer) + (let* ((buffer-read-only nil) + (entry (assoc server gnus-server-alist)) + (oentry (assoc (gnus-server-to-method server) + gnus-opened-servers))) + (when entry + (gnus-dribble-enter + (concat "(gnus-server-set-info \"" server "\" '" + (prin1-to-string (cdr entry)) ")"))) + (when (or entry oentry) + ;; Buffer may be narrowed. + (save-restriction + (widen) + (when (gnus-server-goto-server server) + (gnus-delete-line)) + (if entry + (gnus-server-insert-server-line (car entry) (cdr entry)) + (gnus-server-insert-server-line + (format "%s:%s" (caar oentry) (nth 1 (car oentry))) + (car oentry))) + (gnus-server-position-point)))))) + +(defun gnus-server-set-info (server info) + ;; Enter a select method into the virtual server alist. + (when (and server info) + (gnus-dribble-enter + (concat "(gnus-server-set-info \"" server "\" '" + (prin1-to-string info) ")")) + (let* ((server (nth 1 info)) + (entry (assoc server gnus-server-alist))) + (if entry (setcdr entry info) + (setq gnus-server-alist + (nconc gnus-server-alist (list (cons server info)))))))) + +;;; Interactive server functions. + +(defun gnus-server-kill-server (server) + "Kill the server on the current line." + (interactive (list (gnus-server-server-name))) + (unless (gnus-server-goto-server server) + (if server (error "No such server: %s" server) + (error "No server on the current line"))) + (unless (assoc server gnus-server-alist) + (error "Read-only server %s" server)) + (gnus-dribble-enter "") + (let ((buffer-read-only nil)) + (gnus-delete-line)) + (setq gnus-server-killed-servers + (cons (assoc server gnus-server-alist) gnus-server-killed-servers)) + (setq gnus-server-alist (delq (car gnus-server-killed-servers) + gnus-server-alist)) + (gnus-server-position-point)) + +(defun gnus-server-yank-server () + "Yank the previously killed server." + (interactive) + (or gnus-server-killed-servers + (error "No killed servers to be yanked")) + (let ((alist gnus-server-alist) + (server (gnus-server-server-name)) + (killed (car gnus-server-killed-servers))) + (if (not server) + (setq gnus-server-alist (nconc gnus-server-alist (list killed))) + (if (string= server (caar gnus-server-alist)) + (setq gnus-server-alist (cons killed gnus-server-alist)) + (while (and (cdr alist) + (not (string= server (caadr alist)))) + (setq alist (cdr alist))) + (if alist + (setcdr alist (cons killed (cdr alist))) + (setq gnus-server-alist (list killed))))) + (gnus-server-update-server (car killed)) + (setq gnus-server-killed-servers (cdr gnus-server-killed-servers)) + (gnus-server-position-point))) + +(defun gnus-server-exit () + "Return to the group buffer." + (interactive) + (kill-buffer (current-buffer)) + (switch-to-buffer gnus-group-buffer) + (run-hooks 'gnus-server-exit-hook)) + +(defun gnus-server-list-servers () + "List all available servers." + (interactive) + (let ((cur (gnus-server-server-name))) + (gnus-server-prepare) + (if cur (gnus-server-goto-server cur) + (goto-char (point-max)) + (forward-line -1)) + (gnus-server-position-point))) + +(defun gnus-server-set-status (method status) + "Make METHOD have STATUS." + (let ((entry (assoc method gnus-opened-servers))) + (if entry + (setcar (cdr entry) status) + (push (list method status) gnus-opened-servers)))) + +(defun gnus-opened-servers-remove (method) + "Remove METHOD from the list of opened servers." + (setq gnus-opened-servers (delq (assoc method gnus-opened-servers) + gnus-opened-servers))) + +(defun gnus-server-open-server (server) + "Force an open of SERVER." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (or method (error "No such server: %s" server)) + (gnus-server-set-status method 'ok) + (prog1 + (or (gnus-open-server method) + (progn (message "Couldn't open %s" server) nil)) + (gnus-server-update-server server) + (gnus-server-position-point)))) + +(defun gnus-server-close-server (server) + "Close SERVER." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (or method (error "No such server: %s" server)) + (gnus-server-set-status method 'closed) + (prog1 + (gnus-close-server method) + (gnus-server-update-server server) + (gnus-server-position-point)))) + +(defun gnus-server-deny-server (server) + "Make sure SERVER will never be attempted opened." + (interactive (list (gnus-server-server-name))) + (let ((method (gnus-server-to-method server))) + (or method (error "No such server: %s" server)) + (gnus-server-set-status method 'denied)) + (gnus-server-update-server server) + (gnus-server-position-point) + t) + +(defun gnus-server-remove-denials () + "Make all denied servers into closed servers." + (interactive) + (let ((servers gnus-opened-servers)) + (while servers + (when (eq (nth 1 (car servers)) 'denied) + (setcar (nthcdr 1 (car servers)) 'closed)) + (setq servers (cdr servers)))) + (gnus-server-list-servers)) + +(defun gnus-server-copy-server (from to) + (interactive + (list + (or (gnus-server-server-name) + (error "No server on the current line")) + (read-string "Copy to: "))) + (or from (error "No server on current line")) + (or (and to (not (string= to ""))) (error "No name to copy to")) + (and (assoc to gnus-server-alist) (error "%s already exists" to)) + (or (assoc from gnus-server-alist) + (error "%s: no such server" from)) + (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist)))) + (setcar to-entry to) + (setcar (nthcdr 2 to-entry) to) + (setq gnus-server-killed-servers + (cons to-entry gnus-server-killed-servers)) + (gnus-server-yank-server))) + +(defun gnus-server-add-server (how where) + (interactive + (list (intern (completing-read "Server method: " + gnus-valid-select-methods nil t)) + (read-string "Server name: "))) + (setq gnus-server-killed-servers + (cons (list where how where) gnus-server-killed-servers)) + (gnus-server-yank-server)) + +(defun gnus-server-goto-server (server) + "Jump to a server line." + (interactive + (list (completing-read "Goto server: " gnus-server-alist nil t))) + (let ((to (text-property-any (point-min) (point-max) + 'gnus-server (intern server)))) + (and to + (progn + (goto-char to) + (gnus-server-position-point))))) + +(defun gnus-server-edit-server (server) + "Edit the server on the current line." + (interactive (list (gnus-server-server-name))) + (unless server + (error "No server on current line")) + (unless (assoc server gnus-server-alist) + (error "This server can't be edited")) + (let ((winconf (current-window-configuration)) + (info (cdr (assoc server gnus-server-alist)))) + (gnus-close-server info) + (get-buffer-create gnus-server-edit-buffer) + (gnus-configure-windows 'edit-server) + (gnus-add-current-to-buffer-list) + (emacs-lisp-mode) + (make-local-variable 'gnus-prev-winconf) + (setq gnus-prev-winconf winconf) + (use-local-map (copy-keymap (current-local-map))) + (let ((done-func '(lambda () + "Exit editing mode and update the information." + (interactive) + (gnus-server-edit-server-done 'group)))) + (setcar (cdr (nth 4 done-func)) server) + (local-set-key "\C-c\C-c" done-func)) + (erase-buffer) + (insert ";; Type `C-c C-c' after you have edited the server.\n\n") + (insert (pp-to-string info)))) + +(defun gnus-server-edit-server-done (server) + (interactive) + (set-buffer (get-buffer-create gnus-server-edit-buffer)) + (goto-char (point-min)) + (let ((form (read (current-buffer))) + (winconf gnus-prev-winconf)) + (gnus-server-set-info server form) + (kill-buffer (current-buffer)) + (and winconf (set-window-configuration winconf)) + (set-buffer gnus-server-buffer) + (gnus-server-update-server server) + (gnus-server-list-servers) + (gnus-server-position-point))) + +(defun gnus-server-read-server (server) + "Browse a server." + (interactive (list (gnus-server-server-name))) + (let ((buf (current-buffer))) + (prog1 + (gnus-browse-foreign-server (gnus-server-to-method server) buf) + (save-excursion + (set-buffer buf) + (gnus-server-update-server (gnus-server-server-name)) + (gnus-server-position-point))))) + +(defun gnus-server-pick-server (e) + (interactive "e") + (mouse-set-point e) + (gnus-server-read-server (gnus-server-server-name))) + + +;;; +;;; Browse Server Mode +;;; + +(defvar gnus-browse-menu-hook nil + "*Hook run after the creation of the browse mode menu.") + +(defvar gnus-browse-mode-hook nil) +(defvar gnus-browse-mode-map nil) +(put 'gnus-browse-mode 'mode-class 'special) + +(unless gnus-browse-mode-map + (setq gnus-browse-mode-map (make-keymap)) + (suppress-keymap gnus-browse-mode-map) + + (gnus-define-keys + gnus-browse-mode-map + " " gnus-browse-read-group + "=" gnus-browse-select-group + "n" gnus-browse-next-group + "p" gnus-browse-prev-group + "\177" gnus-browse-prev-group + "N" gnus-browse-next-group + "P" gnus-browse-prev-group + "\M-n" gnus-browse-next-group + "\M-p" gnus-browse-prev-group + "\r" gnus-browse-select-group + "u" gnus-browse-unsubscribe-current-group + "l" gnus-browse-exit + "L" gnus-browse-exit + "q" gnus-browse-exit + "Q" gnus-browse-exit + "\C-c\C-c" gnus-browse-exit + "?" gnus-browse-describe-briefly + + "\C-c\C-i" gnus-info-find-node)) + +(defun gnus-browse-make-menu-bar () + (gnus-visual-turn-off-edit-menu 'browse) + (or + (boundp 'gnus-browse-menu) + (progn + (easy-menu-define + gnus-browse-menu gnus-browse-mode-map "" + '("Browse" + ["Subscribe" gnus-browse-unsubscribe-current-group t] + ["Read" gnus-browse-read-group t] + ["Select" gnus-browse-read-group t] + ["Next" gnus-browse-next-group t] + ["Prev" gnus-browse-next-group t] + ["Exit" gnus-browse-exit t] + )) + (run-hooks 'gnus-browse-menu-hook)))) + +(defvar gnus-browse-current-method nil) +(defvar gnus-browse-return-buffer nil) + +(defvar gnus-browse-buffer "*Gnus Browse Server*") + +(defun gnus-browse-foreign-server (method &optional return-buffer) + "Browse the server METHOD." + (setq gnus-browse-current-method method) + (setq gnus-browse-return-buffer return-buffer) + (let ((gnus-select-method method) + groups group) + (gnus-message 5 "Connecting to %s..." (nth 1 method)) + (cond + ((not (gnus-check-server method)) + (gnus-message + 1 "Unable to contact server: %s" (gnus-status-message method)) + nil) + ((not (gnus-request-list method)) + (gnus-message + 1 "Couldn't request list: %s" (gnus-status-message method)) + nil) + (t + (get-buffer-create gnus-browse-buffer) + (gnus-add-current-to-buffer-list) + (and gnus-carpal (gnus-carpal-setup-buffer 'browse)) + (gnus-configure-windows 'browse) + (buffer-disable-undo (current-buffer)) + (let ((buffer-read-only nil)) + (erase-buffer)) + (gnus-browse-mode) + (setq mode-line-buffer-identification + (list + (format + "Gnus: %%b {%s:%s}" (car method) (cadr method)))) + (save-excursion + (set-buffer nntp-server-buffer) + (let ((cur (current-buffer))) + (goto-char (point-min)) + (or (string= gnus-ignored-newsgroups "") + (delete-matching-lines gnus-ignored-newsgroups)) + (while (re-search-forward + "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t) + (goto-char (match-end 1)) + (setq groups (cons (cons (match-string 1) + (max 0 (- (1+ (read cur)) (read cur)))) + groups))))) + (setq groups (sort groups + (lambda (l1 l2) + (string< (car l1) (car l2))))) + (let ((buffer-read-only nil)) + (while groups + (setq group (car groups)) + (insert + (format "K%7d: %s\n" (cdr group) (car group))) + (setq groups (cdr groups)))) + (switch-to-buffer (current-buffer)) + (goto-char (point-min)) + (gnus-group-position-point) + (gnus-message 5 "Connecting to %s...done" (nth 1 method)) + t)))) + +(defun gnus-browse-mode () + "Major mode for browsing a foreign server. + +All normal editing commands are switched off. + +\\<gnus-browse-mode-map> +The only things you can do in this buffer is + +1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group. +The group will be inserted into the group buffer upon exit from this +buffer. + +2) `\\[gnus-browse-read-group]' to read a group ephemerally. + +3) `\\[gnus-browse-exit]' to return to the group buffer." + (interactive) + (kill-all-local-variables) + (when (and menu-bar-mode + (gnus-visual-p 'browse-menu 'menu)) + (gnus-browse-make-menu-bar)) + (gnus-simplify-mode-line) + (setq major-mode 'gnus-browse-mode) + (setq mode-name "Browse Server") + (setq mode-line-process nil) + (use-local-map gnus-browse-mode-map) + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (setq buffer-read-only t) + (run-hooks 'gnus-browse-mode-hook)) + +(defun gnus-browse-read-group (&optional no-article) + "Enter the group at the current line." + (interactive) + (let ((group (gnus-browse-group-name))) + (or (gnus-group-read-ephemeral-group + group gnus-browse-current-method nil + (cons (current-buffer) 'browse)) + (error "Couldn't enter %s" group)))) + +(defun gnus-browse-select-group () + "Select the current group." + (interactive) + (gnus-browse-read-group 'no)) + +(defun gnus-browse-next-group (n) + "Go to the next group." + (interactive "p") + (prog1 + (forward-line n) + (gnus-group-position-point))) + +(defun gnus-browse-prev-group (n) + "Go to the next group." + (interactive "p") + (gnus-browse-next-group (- n))) + +(defun gnus-browse-unsubscribe-current-group (arg) + "(Un)subscribe to the next ARG groups." + (interactive "p") + (when (eobp) + (error "No group at current line.")) + (let ((ward (if (< arg 0) -1 1)) + (arg (abs arg))) + (while (and (> arg 0) + (not (eobp)) + (gnus-browse-unsubscribe-group) + (zerop (gnus-browse-next-group ward))) + (decf arg)) + (gnus-group-position-point) + (if (/= 0 arg) (gnus-message 7 "No more newsgroups")) + arg)) + +(defun gnus-browse-group-name () + (save-excursion + (beginning-of-line) + (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) + (gnus-group-prefixed-name (match-string 1) gnus-browse-current-method)))) + +(defun gnus-browse-unsubscribe-group () + "Toggle subscription of the current group in the browse buffer." + (let ((sub nil) + (buffer-read-only nil) + group) + (save-excursion + (beginning-of-line) + ;; If this group it killed, then we want to subscribe it. + (if (= (following-char) ?K) (setq sub t)) + (setq group (gnus-browse-group-name)) + (delete-char 1) + (if sub + (progn + (gnus-group-change-level + (list t group gnus-level-default-subscribed + nil nil gnus-browse-current-method) + gnus-level-default-subscribed gnus-level-killed + (and (car (nth 1 gnus-newsrc-alist)) + (gnus-gethash (car (nth 1 gnus-newsrc-alist)) + gnus-newsrc-hashtb)) + t) + (insert ? )) + (gnus-group-change-level + group gnus-level-killed gnus-level-default-subscribed) + (insert ?K))) + t)) + +(defun gnus-browse-exit () + "Quit browsing and return to the group buffer." + (interactive) + (when (eq major-mode 'gnus-browse-mode) + (kill-buffer (current-buffer))) + ;; Insert the newly subscribed groups in the group buffer. + (save-excursion + (set-buffer gnus-group-buffer) + (gnus-group-list-groups nil)) + (if gnus-browse-return-buffer + (gnus-configure-windows 'server 'force) + (gnus-configure-windows 'group 'force))) + +(defun gnus-browse-describe-briefly () + "Give a one line description of the group mode commands." + (interactive) + (gnus-message 6 + (substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help"))) + +(provide 'gnus-srvr) + +;;; gnus-srvr.el ends here.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/gnus-topic.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,1057 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mail/mailheader.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,182 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/message.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,2997 @@ +;;; 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")) + + + +;;; +;;; 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)))) + + + +;;; +;;; 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)) + + + +;;; +;;; 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)))) + + + +(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") ""))) + + + +;;; 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))))) + + + +;;; +;;; 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)))) + + + +;;; +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/nndb.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,229 @@ +;;; nndb.el --- nndb access for Gnus +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de> +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; I have shamelessly snarfed the code of nntp.el from sgnus. +;; Kai + + +;;- +;; Register nndb with known select methods. + +(setq gnus-valid-select-methods + (cons '("nndb" mail address respool prompt-address) + gnus-valid-select-methods)) + + +;;; Code: + +(require 'nnheader) +(require 'nntp) +(eval-when-compile (require 'cl)) + +(eval-and-compile + (unless (fboundp 'open-network-stream) + (require 'tcp))) + +(eval-when-compile (require 'cl)) + +(eval-and-compile + (autoload 'news-setup "rnewspost") + (autoload 'news-reply-mode "rnewspost") + (autoload 'cancel-timer "timer") + (autoload 'telnet "telnet" nil t) + (autoload 'telnet-send-input "telnet" nil t) + (autoload 'timezone-parse-date "timezone")) + +;; Declare nndb as derived from nntp + +(nnoo-declare nndb nntp) + +;; Variables specific to nndb + +;;- currently not used but just in case... +(defvoo nndb-deliver-program "nndel" + "*The program used to put a message in an NNDB group.") + +;; Variables copied from nntp + +(defvoo nndb-server-opened-hook '(nntp-send-authinfo-from-file) + "Like nntp-server-opened-hook." + nntp-server-opened-hook) + +;(defvoo nndb-rlogin-parameters '("telnet" "${NNDBSERVER:=localhost}" "9000") +; "*Parameters to nndb-open-login. Like nntp-rlogin-parameters." +; nntp-rlogin-parameters) + +;(defvoo nndb-rlogin-user-name nil +; "*User name for rlogin connect method." +; nntp-rlogin-user-name) + +(defvoo nndb-address "localhost" + "*The name of the NNDB server." + nntp-address) + +(defvoo nndb-port-number 9000 + "*Port number to connect to." + nntp-port-number) + +;(defvoo nndb-current-group "" +; "Like nntp-current-group." +; nntp-current-group) + +(defvoo nndb-status-string nil "" nntp-status-string) + + + +(defconst nndb-version "nndb 0.3" + "Version numbers of this version of NNDB.") + + +;;; Interface functions. + +(nnoo-define-basics nndb) + +;; Import other stuff from nntp as is. + +(nnoo-import nndb + (nntp)) + +;;- maybe this should be mail?? +;;-(defun nndb-request-type (group &optional article) +;;- 'news) + +;;------------------------------------------------------------------ +;;- only new stuff below + +; nndb-request-update-info does not exist and is not needed + +; nndb-request-update-mark does not exist and is not needed + +; nndb-request-scan does not exist +; get new mail from somewhere -- maybe this is not needed? +; --> todo + +(deffoo nndb-request-create-group (group &optional server) + "Creates a group if it doesn't exist yet." + (nntp-send-command "^[23].*\n" "MKGROUP" group)) + +; todo -- use some other time than the creation time of the article +; best is time since article has been marked as expirable +(deffoo nndb-request-expire-articles + (articles &optional group server force) + "Expires ARTICLES from GROUP on SERVER. +If FORCE, delete regardless of exiration date, otherwise use normal +expiry mechanism." + (let (msg art) + (nntp-possibly-change-server group server) ;;- + (while articles + (setq art (pop articles)) + (nntp-send-command "^\\([23]\\|^423\\).*\n" "DATE" art) + (setq msg (nndb-status-message)) + ;; CCC we shouldn't be using the variable nndb-status-string? + (if (string-match "^423" (nnheader-get-report 'nndb)) + () + (or (string-match "\\([0-9]+\\) \\([0-9]+\\)$" msg) + (error "Not a valid response for DATE command: %s" + msg)) + (if (nnmail-expired-article-p + group + (list (string-to-int + (substring msg (match-beginning 1) (match-end 1))) + (string-to-int + (substring msg (match-beginning 2) (match-end 2)))) + force) + (nnheader-message 5 "Deleting article %s in %s..." + art group) + (nntp-send-command "^[23].*\n" "DELETE" art)))))) + +(deffoo nndb-request-move-article + (article group server accept-form &optional last) + "Move ARTICLE (a number) from GROUP on SERVER. +Evals ACCEPT-FORM in current buffer, where the article is. +Optional LAST is ignored." + (let ((artbuf (get-buffer-create " *nndb move*")) + result) + (and + (nndb-request-article article group server artbuf) + (save-excursion + (set-buffer artbuf) + (setq result (eval accept-form)) + (kill-buffer (current-buffer)) + result) + (nndb-request-expire-articles (list article) + group + server + t)) + result)) + +(deffoo nndb-request-accept-article (group server &optional last) + "The article in the current buffer is put into GROUP." + (nntp-possibly-change-server group server) ;;- + (let (art statmsg) + (when (nntp-send-command "^[23].*\r?\n" "ACCEPT" group) + (nnheader-insert "") + (nntp-encode-text) + (nntp-send-region-to-server (point-min) (point-max)) + ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not + ;; appended to end of the status message. + (nntp-wait-for-response "^[23].*\n") + (setq statmsg (nntp-status-message)) + (or (string-match "^\\([0-9]+\\)" statmsg) + (error "nndb: %s" statmsg)) + (setq art (substring statmsg + (match-beginning 1) + (match-end 1))) + (message "nndb: accepted %s" art) + (list art)))) + +(deffoo nndb-request-replace-article (article group buffer) + "ARTICLE is the number of the article in GROUP to be replaced +with the contents of the BUFFER." + (set-buffer buffer) + (let (art statmsg) + (when (nntp-send-command "^[23].*\r?\n" "REPLACE" (int-to-string article)) + (nnheader-insert "") + (nntp-encode-text) + (nntp-send-region-to-server (point-min) (point-max)) + ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not + ;; appended to end of the status message. + (nntp-wait-for-response "^[23].*\n") +; (setq statmsg (nntp-status-message)) +; (or (string-match "^\\([0-9]+\\)" statmsg) +; (error "nndb: %s" statmsg)) +; (setq art (substring statmsg +; (match-beginning 1) +; (match-end 1))) +; (message "nndb: replaced %s" art) + (list (int-to-string article))))) + +; nndb-request-delete-group does not exist +; todo -- maybe later + +; nndb-request-rename-group does not exist +; todo -- maybe later + +(provide 'nndb) + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/nnheaderems.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,201 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/nnoo.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,251 @@ +;;; 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 Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/nnsoup.el Tue Jun 25 22:35:26 1996 +0000 @@ -0,0 +1,747 @@ +;;; nnsoup.el --- SOUP access for Gnus +;; Copyright (C) 1995,96 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> +;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> +;; Keywords: news, mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(require 'nnheader) +(require 'nnmail) +(require 'gnus-soup) +(require 'gnus-msg) +(require 'nnoo) +(eval-when-compile (require 'cl)) + +(nnoo-declare nnsoup) + +(defvoo nnsoup-directory "~/SOUP/" + "*SOUP packet directory.") + +(defvoo nnsoup-tmp-directory "/tmp/" + "*Where nnsoup will store temporary files.") + +(defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/") + "*Directory where outgoing packets will be composed.") + +(defvoo nnsoup-replies-format-type ?n + "*Format of the replies packages.") + +(defvoo nnsoup-replies-index-type ?n + "*Index type of the replies packages.") + +(defvoo nnsoup-active-file (concat nnsoup-directory "active") + "Active file.") + +(defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz" + "Format string command for packing a SOUP packet. +The SOUP files will be inserted where the %s is in the string. +This string MUST contain both %s and %d. The file number will be +inserted where %d appears.") + +(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -" + "*Format string command for unpacking a SOUP packet. +The SOUP packet file name will be inserted at the %s.") + +(defvoo nnsoup-packet-directory "~/" + "*Where nnsoup will look for incoming packets.") + +(defvoo nnsoup-packet-regexp "Soupout" + "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.") + + + +(defconst nnsoup-version "nnsoup 0.0" + "nnsoup version.") + +(defvoo nnsoup-status-string "") +(defvoo nnsoup-group-alist nil) +(defvoo nnsoup-current-prefix 0) +(defvoo nnsoup-replies-list nil) +(defvoo nnsoup-buffers nil) +(defvoo nnsoup-current-group nil) +(defvoo nnsoup-group-alist-touched nil) + + + +;;; Interface functions. + +(nnoo-define-basics nnsoup) + +(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old) + (nnsoup-possibly-change-group group) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist))) + (articles sequence) + (use-nov t) + useful-areas this-area-seq msg-buf) + (if (stringp (car sequence)) + ;; We don't support fetching by Message-ID. + 'headers + ;; We go through all the areas and find which files the + ;; articles in SEQUENCE come from. + (while (and areas sequence) + ;; Peel off areas that are below sequence. + (while (and areas (< (cdaar areas) (car sequence))) + (setq areas (cdr areas))) + (when areas + ;; This is a useful area. + (push (car areas) useful-areas) + (setq this-area-seq nil) + ;; We take note whether this MSG has a corresponding IDX + ;; for later use. + (when (or (= (gnus-soup-encoding-index + (gnus-soup-area-encoding (nth 1 (car areas)))) ?n) + (not (file-exists-p + (nnsoup-file + (gnus-soup-area-prefix (nth 1 (car areas))))))) + (setq use-nov nil)) + ;; We assign the portion of `sequence' that is relevant to + ;; this MSG packet to this packet. + (while (and sequence (<= (car sequence) (cdaar areas))) + (push (car sequence) this-area-seq) + (setq sequence (cdr sequence))) + (setcar useful-areas (cons (nreverse this-area-seq) + (car useful-areas))))) + + ;; We now have a list of article numbers and corresponding + ;; areas. + (setq useful-areas (nreverse useful-areas)) + + ;; Two different approaches depending on whether all the MSG + ;; files have corresponding IDX files. If they all do, we + ;; simply return the relevant IDX files and let Gnus sort out + ;; what lines are relevant. If some of the IDX files are + ;; missing, we must return HEADs for all the articles. + (if use-nov + ;; We have IDX files for all areas. + (progn + (while useful-areas + (goto-char (point-max)) + (let ((b (point)) + (number (car (nth 1 (car useful-areas)))) + (index-buffer (nnsoup-index-buffer + (gnus-soup-area-prefix + (nth 2 (car useful-areas)))))) + (when index-buffer + (insert-buffer-substring index-buffer) + (goto-char b) + ;; We have to remove the index number entires and + ;; insert article numbers instead. + (while (looking-at "[0-9]+") + (replace-match (int-to-string number) t t) + (incf number) + (forward-line 1)))) + (setq useful-areas (cdr useful-areas))) + 'nov) + ;; We insert HEADs. + (while useful-areas + (setq articles (caar useful-areas) + useful-areas (cdr useful-areas)) + (while articles + (when (setq msg-buf + (nnsoup-narrow-to-article + (car articles) (cdar useful-areas) 'head)) + (goto-char (point-max)) + (insert (format "221 %d Article retrieved.\n" (car articles))) + (insert-buffer-substring msg-buf) + (goto-char (point-max)) + (insert ".\n")) + (setq articles (cdr articles)))) + + (nnheader-fold-continuation-lines) + 'headers))))) + +(deffoo nnsoup-open-server (server &optional defs) + (nnoo-change-server 'nnsoup server defs) + (when (not (file-exists-p nnsoup-directory)) + (condition-case () + (make-directory nnsoup-directory t) + (error t))) + (cond + ((not (file-exists-p nnsoup-directory)) + (nnsoup-close-server) + (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory)) + ((not (file-directory-p (file-truename nnsoup-directory))) + (nnsoup-close-server) + (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory)) + (t + (nnsoup-read-active-file) + (nnheader-report 'nnsoup "Opened server %s using directory %s" + server nnsoup-directory) + t))) + +(deffoo nnsoup-request-close () + (nnsoup-write-active-file) + (nnsoup-write-replies) + (gnus-soup-save-areas) + ;; Kill all nnsoup buffers. + (let (buffer) + (while nnsoup-buffers + (setq buffer (cdr (pop nnsoup-buffers))) + (and buffer + (buffer-name buffer) + (kill-buffer buffer)))) + (setq nnsoup-group-alist nil + nnsoup-group-alist-touched nil + nnsoup-current-group nil + nnsoup-replies-list nil) + (nnoo-close-server 'nnoo) + t) + +(deffoo nnsoup-request-article (id &optional newsgroup server buffer) + (nnsoup-possibly-change-group newsgroup) + (let (buf) + (save-excursion + (set-buffer (or buffer nntp-server-buffer)) + (erase-buffer) + (when (and (not (stringp id)) + (setq buf (nnsoup-narrow-to-article id))) + (insert-buffer-substring buf) + t)))) + +(deffoo nnsoup-request-group (group &optional server dont-check) + (nnsoup-possibly-change-group group) + (if dont-check + t + (let ((active (cadr (assoc group nnsoup-group-alist)))) + (if (not active) + (nnheader-report 'nnsoup "No such group: %s" group) + (nnheader-insert + "211 %d %d %d %s\n" + (max (1+ (- (cdr active) (car active))) 0) + (car active) (cdr active) group))))) + +(deffoo nnsoup-request-type (group &optional article) + (nnsoup-possibly-change-group group) + (if (not article) + 'unknown + (let ((kind (gnus-soup-encoding-kind + (gnus-soup-area-encoding + (nth 1 (nnsoup-article-to-area + article nnsoup-current-group)))))) + (cond ((= kind ?m) 'mail) + ((= kind ?n) 'news) + (t 'unknown))))) + +(deffoo nnsoup-close-group (group &optional server) + ;; Kill all nnsoup buffers. + (let ((buffers nnsoup-buffers) + elem) + (while buffers + (when (equal (car (setq elem (pop buffers))) group) + (setq nnsoup-buffers (delq elem nnsoup-buffers)) + (and (cdr elem) (buffer-name (cdr elem)) + (kill-buffer (cdr elem)))))) + t) + +(deffoo nnsoup-request-list (&optional server) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (unless nnsoup-group-alist + (nnsoup-read-active-file)) + (let ((alist nnsoup-group-alist) + (standard-output (current-buffer)) + entry) + (while (setq entry (pop alist)) + (insert (car entry) " ") + (princ (cdadr entry)) + (insert " ") + (princ (caadr entry)) + (insert " y\n")) + t))) + +(deffoo nnsoup-request-scan (group &optional server) + (nnsoup-unpack-packets)) + +(deffoo nnsoup-request-newgroups (date &optional server) + (nnsoup-request-list)) + +(deffoo nnsoup-request-list-newsgroups (&optional server) + nil) + +(deffoo nnsoup-request-post (&optional server) + (nnsoup-store-reply "news") + t) + +(deffoo nnsoup-request-mail (&optional server) + (nnsoup-store-reply "mail") + t) + +(deffoo nnsoup-request-expire-articles (articles group &optional server force) + (nnsoup-possibly-change-group group) + (let* ((total-infolist (assoc group nnsoup-group-alist)) + (active (cadr total-infolist)) + (infolist (cddr total-infolist)) + info range-list mod-time prefix) + (while infolist + (setq info (pop infolist) + range-list (gnus-uncompress-range (car info)) + prefix (gnus-soup-area-prefix (nth 1 info))) + (when ;; All the articles in this file are marked for expiry. + (and (or (setq mod-time (nth 5 (file-attributes + (nnsoup-file prefix)))) + (setq mod-time (nth 5 (file-attributes + (nnsoup-file prefix t))))) + (gnus-sublist-p articles range-list) + ;; This file is old enough. + (nnmail-expired-article-p group mod-time force)) + ;; Ok, we delete this file. + (when (condition-case nil + (progn + (nnheader-message + 5 "Deleting %s in group %s..." (nnsoup-file prefix) + group) + (when (file-exists-p (nnsoup-file prefix)) + (delete-file (nnsoup-file prefix))) + (nnheader-message + 5 "Deleting %s in group %s..." (nnsoup-file prefix t) + group) + (when (file-exists-p (nnsoup-file prefix t)) + (delete-file (nnsoup-file prefix t))) + t) + (error nil)) + (setcdr (cdr total-infolist) (delq info (cddr total-infolist))) + (setq articles (gnus-sorted-complement articles range-list)))) + (when (not mod-time) + (setcdr (cdr total-infolist) (delq info (cddr total-infolist))))) + (if (cddr total-infolist) + (setcar active (caaadr (cdr total-infolist))) + (setcar active (1+ (cdr active)))) + (nnsoup-write-active-file t) + ;; Return the articles that weren't expired. + articles)) + + +;;; Internal functions + +(defun nnsoup-possibly-change-group (group &optional force) + (if group + (setq nnsoup-current-group group) + t)) + +(defun nnsoup-read-active-file () + (setq nnsoup-group-alist nil) + (when (file-exists-p nnsoup-active-file) + (condition-case () + (load nnsoup-active-file t t t) + (error nil)) + ;; Be backwards compatible. + (when (and nnsoup-group-alist + (not (atom (caadar nnsoup-group-alist)))) + (let ((alist nnsoup-group-alist) + entry e min max) + (while (setq e (cdr (setq entry (pop alist)))) + (setq min (caaar e)) + (while (cdr e) + (setq e (cdr e))) + (setq max (cdaar e)) + (setcdr entry (cons (cons min max) (cdr entry))))) + (setq nnsoup-group-alist-touched t)) + nnsoup-group-alist)) + +(defun nnsoup-write-active-file (&optional force) + (when (and nnsoup-group-alist + (or force + nnsoup-group-alist-touched)) + (setq nnsoup-group-alist-touched nil) + (nnheader-temp-write nnsoup-active-file + (let ((standard-output (current-buffer))) + (prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist)) + (insert "\n") + (prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix)) + (insert "\n"))))) + +(defun nnsoup-next-prefix () + "Return the next free prefix." + (let (prefix) + (while (or (file-exists-p + (nnsoup-file (setq prefix (int-to-string + nnsoup-current-prefix)))) + (file-exists-p (nnsoup-file prefix t))) + (incf nnsoup-current-prefix)) + (incf nnsoup-current-prefix) + prefix)) + +(defun nnsoup-read-areas () + (save-excursion + (set-buffer nntp-server-buffer) + (let ((areas (gnus-soup-parse-areas (concat nnsoup-tmp-directory "AREAS"))) + entry number area lnum cur-prefix file) + ;; Go through all areas in the new AREAS file. + (while (setq area (pop areas)) + ;; Change the name to the permanent name and move the files. + (setq cur-prefix (nnsoup-next-prefix)) + (message "Incorporating file %s..." cur-prefix) + (when (file-exists-p + (setq file (concat nnsoup-tmp-directory + (gnus-soup-area-prefix area) ".IDX"))) + (rename-file file (nnsoup-file cur-prefix))) + (when (file-exists-p + (setq file (concat nnsoup-tmp-directory + (gnus-soup-area-prefix area) ".MSG"))) + (rename-file file (nnsoup-file cur-prefix t)) + (gnus-soup-set-area-prefix area cur-prefix) + ;; Find the number of new articles in this area. + (setq number (nnsoup-number-of-articles area)) + (if (not (setq entry (assoc (gnus-soup-area-name area) + nnsoup-group-alist))) + ;; If this is a new area (group), we just add this info to + ;; the group alist. + (push (list (gnus-soup-area-name area) + (cons 1 number) + (list (cons 1 number) area)) + nnsoup-group-alist) + ;; There are already articles in this group, so we add this + ;; info to the end of the entry. + (nconc entry (list (list (cons (1+ (setq lnum (cdadr entry))) + (+ lnum number)) + area))) + (setcdr (cadr entry) (+ lnum number)))))) + (nnsoup-write-active-file t) + (delete-file (concat nnsoup-tmp-directory "AREAS")))) + +(defun nnsoup-number-of-articles (area) + (save-excursion + (cond + ;; If the number is in the area info, we just return it. + ((gnus-soup-area-number area) + (gnus-soup-area-number area)) + ;; If there is an index file, we just count the lines. + ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n) + (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area))) + (count-lines (point-min) (point-max))) + ;; We do it the hard way - re-searching through the message + ;; buffer. + (t + (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area))) + (goto-char (point-min)) + (let ((regexp (nnsoup-header (gnus-soup-encoding-format + (gnus-soup-area-encoding area)))) + (num 0)) + (while (re-search-forward regexp nil t) + (setq num (1+ num))) + num))))) + +(defun nnsoup-index-buffer (prefix &optional message) + (let* ((file (concat prefix (if message ".MSG" ".IDX"))) + (buffer-name (concat " *nnsoup " file "*"))) + (or (get-buffer buffer-name) ; File aready loaded. + (when (file-exists-p (concat nnsoup-directory file)) + (save-excursion ; Load the file. + (set-buffer (get-buffer-create buffer-name)) + (buffer-disable-undo (current-buffer)) + (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers) + (insert-file-contents (concat nnsoup-directory file)) + (current-buffer)))))) + +(defun nnsoup-file (prefix &optional message) + (expand-file-name + (concat nnsoup-directory prefix (if message ".MSG" ".IDX")))) + +(defun nnsoup-message-buffer (prefix) + (nnsoup-index-buffer prefix 'msg)) + +(defun nnsoup-unpack-packets () + "Unpack all packets in `nnsoup-packet-directory'." + (let ((packets (directory-files + nnsoup-packet-directory t nnsoup-packet-regexp)) + packet) + (while (setq packet (pop packets)) + (message (format "nnsoup: unpacking %s..." packet)) + (if (not (gnus-soup-unpack-packet + nnsoup-tmp-directory nnsoup-unpacker packet)) + (message "Couldn't unpack %s" packet) + (delete-file packet) + (nnsoup-read-areas) + (message "Unpacking...done"))))) + +(defun nnsoup-narrow-to-article (article &optional area head) + (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group))) + (prefix (and area (gnus-soup-area-prefix (nth 1 area)))) + (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg))) + beg end) + (when area + (save-excursion + (cond + ;; There is no MSG file. + ((null msg-buf) + nil) + + ;; We use the index file to find out where the article begins and ends. + ((and (= (gnus-soup-encoding-index + (gnus-soup-area-encoding (nth 1 area))) + ?c) + (file-exists-p (nnsoup-file prefix))) + (set-buffer (nnsoup-index-buffer prefix)) + (widen) + (goto-char (point-min)) + (forward-line (- article (caar area))) + (setq beg (read (current-buffer))) + (forward-line 1) + (if (looking-at "[0-9]+") + (progn + (setq end (read (current-buffer))) + (set-buffer msg-buf) + (widen) + (let ((format (gnus-soup-encoding-format + (gnus-soup-area-encoding (nth 1 area))))) + (goto-char end) + (if (or (= format ?n) (= format ?m)) + (setq end (progn (forward-line -1) (point)))))) + (set-buffer msg-buf)) + (widen) + (narrow-to-region beg (or end (point-max)))) + (t + (set-buffer msg-buf) + (widen) + (goto-char (point-min)) + (let ((header (nnsoup-header + (gnus-soup-encoding-format + (gnus-soup-area-encoding (nth 1 area)))))) + (re-search-forward header nil t (- article (caar area))) + (narrow-to-region + (match-beginning 0) + (if (re-search-forward header nil t) + (match-beginning 0) + (point-max)))))) + (goto-char (point-min)) + (if (not head) + () + (narrow-to-region + (point-min) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max)))) + msg-buf)))) + +(defun nnsoup-header (format) + (cond + ((= format ?n) + "^#! *rnews +[0-9]+ *$") + ((= format ?m) + (concat "^" message-unix-mail-delimiter)) + ((= format ?M) + "^\^A\^A\^A\^A\n") + (t + (error "Unknown format: %c" format)))) + +;;;###autoload +(defun nnsoup-pack-replies () + "Make an outbound package of SOUP replies." + (interactive) + ;; Write all data buffers. + (gnus-soup-save-areas) + ;; Write the active file. + (nnsoup-write-active-file) + ;; Write the REPLIES file. + (nnsoup-write-replies) + ;; Pack all these files into a SOUP packet. + (gnus-soup-pack nnsoup-replies-directory nnsoup-packer)) + +(defun nnsoup-write-replies () + "Write the REPLIES file." + (when nnsoup-replies-list + (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list) + (setq nnsoup-replies-list nil))) + +(defun nnsoup-article-to-area (article group) + "Return the area that ARTICLE in GROUP is located in." + (let ((areas (cddr (assoc group nnsoup-group-alist)))) + (while (and areas (< (cdaar areas) article)) + (setq areas (cdr areas))) + (and areas (car areas)))) + +(defvar nnsoup-old-functions + (list message-send-mail-function message-send-news-function)) + +;;;###autoload +(defun nnsoup-set-variables () + "Use the SOUP methods for posting news and mailing mail." + (interactive) + (setq message-send-news-function 'nnsoup-request-post) + (setq message-send-mail-function 'nnsoup-request-mail)) + +;;;###autoload +(defun nnsoup-revert-variables () + "Revert posting and mailing methods to the standard Emacs methods." + (interactive) + (setq message-send-mail-function (car nnsoup-old-functions)) + (setq message-send-news-function (cadr nnsoup-old-functions))) + +(defun nnsoup-store-reply (kind) + ;; Mostly stolen from `message.el'. + (require 'mail-utils) + (let ((tembuf (generate-new-buffer " message temp")) + (case-fold-search nil) + (news (message-news-p)) + (resend-to-addresses (mail-fetch-field "resent-to")) + delimline + (mailbuf (current-buffer))) + (unwind-protect + (save-excursion + (save-restriction + (message-narrow-to-headers) + (if (equal kind "mail") + (message-generate-headers message-required-mail-headers) + (message-generate-headers message-required-news-headers))) + (set-buffer tembuf) + (erase-buffer) + (insert-buffer-substring mailbuf) + ;; Remove some headers. + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (when (and news + (equal kind "mail") + (or (mail-fetch-field "cc") + (mail-fetch-field "to"))) + (message-insert-courtesy-copy)) + (let ((case-fold-search t)) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (when (eval message-mailer-swallows-blank-line) + (newline)) + (let ((msg-buf + (gnus-soup-store + nnsoup-replies-directory + (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type + nnsoup-replies-index-type)) + (num 0)) + (when (and msg-buf (bufferp msg-buf)) + (save-excursion + (set-buffer msg-buf) + (goto-char (point-min)) + (while (re-search-forward "^#! *rnews" nil t) + (incf num))) + (message "Stored %d messages" num))) + (nnsoup-write-replies) + (kill-buffer tembuf)))))) + +(defun nnsoup-kind-to-prefix (kind) + (unless nnsoup-replies-list + (setq nnsoup-replies-list + (gnus-soup-parse-replies + (concat nnsoup-replies-directory "REPLIES")))) + (let ((replies nnsoup-replies-list)) + (while (and replies + (not (string= kind (gnus-soup-reply-kind (car replies))))) + (setq replies (cdr replies))) + (if replies + (gnus-soup-reply-prefix (car replies)) + (setq nnsoup-replies-list + (cons (vector (gnus-soup-unique-prefix nnsoup-replies-directory) + kind + (format "%c%c%c" + nnsoup-replies-format-type + nnsoup-replies-index-type + (if (string= kind "news") + ?n ?m))) + nnsoup-replies-list)) + (gnus-soup-reply-prefix (car nnsoup-replies-list))))) + +(defun nnsoup-make-active () + "(Re-)create the SOUP active file." + (interactive) + (let ((files (sort (directory-files nnsoup-directory t "IDX$") + (lambda (f1 f2) + (< (progn (string-match "/\\([0-9]+\\)\\." f1) + (string-to-int (match-string 1 f1))) + (progn (string-match "/\\([0-9]+\\)\\." f2) + (string-to-int (match-string 1 f2))))))) + active group lines ident elem min) + (set-buffer (get-buffer-create " *nnsoup work*")) + (buffer-disable-undo (current-buffer)) + (while files + (message "Doing %s..." (car files)) + (erase-buffer) + (insert-file-contents (car files)) + (goto-char (point-min)) + (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t)) + (setq group "unknown") + (setq group (match-string 2))) + (setq lines (count-lines (point-min) (point-max))) + (setq ident (progn (string-match + "/\\([0-9]+\\)\\." (car files)) + (substring + (car files) (match-beginning 1) + (match-end 1)))) + (if (not (setq elem (assoc group active))) + (push (list group (cons 1 lines) + (list (cons 1 lines) + (vector ident group "ncm" "" lines))) + active) + (nconc elem + (list + (list (cons (1+ (setq min (cdadr elem))) + (+ min lines)) + (vector ident group "ncm" "" lines)))) + (setcdr (cadr elem) (+ min lines))) + (setq files (cdr files))) + (message "") + (setq nnsoup-group-alist active) + (nnsoup-write-active-file t))) + +(defun nnsoup-delete-unreferenced-message-files () + "Delete any *.MSG and *.IDX files that aren't known by nnsoup." + (interactive) + (let* ((known (apply 'nconc (mapcar + (lambda (ga) + (mapcar + (lambda (area) + (gnus-soup-area-prefix (cadr area))) + (cddr ga))) + nnsoup-group-alist))) + (regexp "\\.MSG$\\|\\.IDX$") + (files (directory-files nnsoup-directory nil regexp)) + non-files file) + ;; Find all files that aren't known by nnsoup. + (while (setq file (pop files)) + (string-match regexp file) + (unless (member (substring file 0 (match-beginning 0)) known) + (push file non-files))) + ;; Sort and delete the files. + (setq non-files (sort non-files 'string<)) + (map-y-or-n-p "Delete file %s? " + (lambda (file) (delete-file (concat nnsoup-directory file))) + non-files))) + +(provide 'nnsoup) + +;;; nnsoup.el ends here