/[cmucl]/src/hemlock/netnews.lisp
ViewVC logotype

Contents of /src/hemlock/netnews.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Jul 30 10:26:04 1991 UTC (22 years, 8 months ago) by chiles
Branch: MAIN
Changes since 1.2: +0 -57 lines
Removed bindings from this file and put them in bindings.lisp.
1 ;;; -*- Package: Hemlock; Log: hemlock.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Written by Blaine Burks
12 ;;;
13 ;;; This file implements the reading of bulletin boards from within Hemlock
14 ;;; via a known NNTP server. Something should probably be done so that
15 ;;; when the server is down Hemlock doesn't hang as I suspect it will.
16 ;;;
17 ;;; Warning: Throughout this file, it may appear I should have bound
18 ;;; the nn-info-stream and nn-info-header-stream slots instead
19 ;;; of making multiple structure accesses. This was done on
20 ;;; purpose because we don't find out if NNTP timed us out until
21 ;;; we make an attempt to execute another command. This code
22 ;;; recovers by resetting the header-stream and stream slots in
23 ;;; the nn-info structure to new streams. If the structure
24 ;;; access were not made again and NNTP had timed us out, we
25 ;;; would be making requests on a defunct stream.
26 ;;;
27 (in-package "HEMLOCK")
28
29
30
31 ;;;; Netnews mode.
32
33 (defparameter default-netnews-headers-length 1000
34 "How long the header-cache and message-ids arrays should be made on startup.")
35
36 (defstruct (netnews-info
37 (:conc-name nn-info-)
38 (:print-function
39 (lambda (nn s d)
40 (declare (ignore nn d))
41 (write-string "#<Netnews Info>" s))))
42 ;;
43 (updatep (ext:required-argument) :type (or null t))
44 (from-end-p nil :type (or null t))
45 ;; The string name of the current bboard.
46 (current (ext:required-argument) :type simple-string)
47 ;; The number of the latest message read in the current group.
48 (latest nil :type (or null fixnum))
49 ;; The cache of header info for the current bboard. Each element contains
50 ;; an association list of header fields to contents of those fields. Indexed
51 ;; by id offset by the first message in the group.
52 ;;
53 (header-cache nil :type (or null vector))
54 ;; The number of HEAD requests currently waiting on the header stream.
55 ;;
56 (batch-count nil :type (or null fixnum))
57 ;; The list of newsgroups to read.
58 (groups (ext:required-argument) :type cons)
59 ;; A vector of message ids indexed by buffer-line for this headers buffer.
60 (message-ids nil :type (or null vector))
61 ;; Where to insert the next batch of headers.
62 mark
63 ;; The message buffer used to view article bodies.
64 buffer
65 ;; A list of message buffers that have been marked as undeletable by the user.
66 (other-buffers nil :type (or null cons))
67 ;; The window used to display buffer when \"Netnews Read Style\" is :multiple.
68 message-window
69 ;; The window used to display headers when \"Netnews Read Style\" is :multiple.
70 headers-window
71 ;; How long the message-ids and header-cache arrays are. Reuse this array,
72 ;; but don't break if there are more messages than we can handle.
73 (array-length default-netnews-headers-length :type fixnum)
74 ;; The id of the first message in the current group.
75 (first nil :type (or null fixnum))
76 ;; The id of the last message in the current-group.
77 (last nil :type (or null fixnum))
78 ;; Article number of the first visible header.
79 (first-visible nil :type (or null fixnum))
80 ;; Article number of the last visible header.
81 (last-visible nil :type (or null fixnum))
82 ;; Number of the message that is currently displayed in buffer. Initialize
83 ;; to -1 so I don't have to constantly check for the nullness of it.
84 (current-displayed-message -1 :type (or null fixnum))
85 ;; T if the last batch of headers is waiting on the header stream.
86 ;; This is needed so NN-WRITE-HEADERS-TO-MARK can set the messages-waiting
87 ;; slot to nil.
88 (last-batch-p nil :type (or null t))
89 ;; T if there are more headers in the current group. Nil otherwise.
90 (messages-waiting nil :type (or null t))
91 ;; The stream on which we request headers from NNTP.
92 header-stream
93 ;; The stream on which we request everything but headers from NNTP.
94 stream)
95
96 (defmode "News-Headers" :major-p t)
97
98
99
100 ;;;; The netnews-message-info and post-info structures.
101
102 (defstruct (netnews-message-info
103 (:conc-name nm-info-)
104 (:print-function
105 (lambda (nn s d)
106 (declare (ignore nn d))
107 (write-string "#<Netnews Message Info>" s))))
108 ;; The headers buffer (if there is one) associated with this message buffer.
109 headers-buffer
110 ;; The draft buffer (if there is one) associated with this message buffer.
111 draft-buffer
112 ;; The post buffer (if there is one) associated with this message buffer.
113 post-buffer
114 ;; This is need because we want to display what message this is in the
115 ;; modeline field of a message buffer.
116 (message-number :type (or null fixnum))
117 ;; Set to T when we do not want to reuse this buffer.
118 keep-p)
119
120 (defstruct (post-info
121 (:print-function
122 (lambda (nn s d)
123 (declare (ignore nn d))
124 (write-string "#<Post Info>" s))))
125 ;; The NNTP stream over which to send this post.
126 stream
127 ;; When replying in another window, the reply window.
128 reply-window
129 ;; When replying in another window, the message window.
130 message-window
131 ;; The message buffer associated with this post.
132 message-buffer
133 ;; The Headers buffer associated with this post.
134 headers-buffer)
135
136
137
138 ;;;; Command Level Implementation of "News-Headers" mode.
139
140 (defhvar "Netnews Database Filename"
141 "This value is merged with your home directory to get a path to your netnews
142 pointers file."
143 :value ".hemlock-netnews")
144
145 (defhvar "Netnews Read Style"
146 "How you like to read netnews. A value of :single will cause netnews
147 mode to use a single window for headers and messages, and a value of
148 :multiple will cause the current window to be split so that Headers take
149 up 25% of what was the current window, and a message bodies buffer the
150 remaining 75%. Changing the value of this variable dynamically affects
151 netnews reading." :value :multiple)
152
153 (unless (modeline-field :netnews-message)
154 (make-modeline-field
155 :name :netnews-message
156 :width 14
157 :function #'(lambda (buffer window)
158 (declare (ignore window))
159 (let* ((nm-info (variable-value 'netnews-message-info
160 :buffer buffer))
161 (nn-info (variable-value 'netnews-info
162 :buffer (nm-info-headers-buffer
163 nm-info))))
164 (format nil "~D of ~D"
165 (nm-info-message-number nm-info)
166 (1+ (- (nn-info-last nn-info)
167 (nn-info-first nn-info))))))))
168
169 (unless (modeline-field :netnews-header-info)
170 (make-modeline-field
171 :name :netnews-header-info
172 :width 24
173 :function
174 #'(lambda (buffer window)
175 (declare (ignore window))
176 (let ((nn-info (variable-value 'netnews-info :buffer buffer)))
177 (format nil "~D before, ~D after"
178 (- (nn-info-first-visible nn-info) (nn-info-first nn-info))
179 (- (nn-info-last nn-info) (nn-info-last-visible nn-info)))))))
180
181 (defvar *nn-headers-buffer* nil
182 "If \"Netnews\" was invoked without an argument an not exited, this
183 holds the headers buffer for reading netnews.")
184
185 (defvar *netnews-kill-strings* nil)
186
187 (defhvar "Netnews Kill File"
188 "This value is merged with your home directory to get the pathname of
189 your netnews kill file. If any of the strings in this file (one per
190 line) appear in a subject header while reading netnews, they will have a
191 \"K\" in front of them, and \"Netnews Next Line\" and \"Netnews Previous
192 Line\" will never land you on one. Use \"Next Line\" and \"Previous
193 Line\" to read Killed messages. Defaults to \".hemlock-kill\"."
194 :value ".hemlock-kill")
195
196 (defhvar "Netnews New Board Style"
197 "Determines what happend when you read a bboard that you have never read
198 before. When :from-start, \"Netnews\" will read from the beginning of a
199 new group forward. When :from-end, the default, \"Netnews\" will read
200 from the end backward group. Otherwise this variable is a number
201 indicating that \"Netnews\" should start that many messages from the end
202 of the group and read forward from there."
203 :value :from-end)
204
205 (defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t))
206 "Enter a headers buffer and read bboards from \"Netnews Group File\". With
207 an argument prompts for a group and reads it."
208 "Enter a headers buffer and read bboards from \"Netnews Group File\". With
209 an argument prompts for a group and reads it."
210 (cond
211 ((and *nn-headers-buffer* (not p) (not group-name))
212 (change-to-buffer *nn-headers-buffer*))
213 (t
214 (let* ((single-group (if p (prompt-for-string :prompt "Group to read: "
215 :help "Type the name of ~
216 the bboard you want ~
217 to scan."
218 :trim t)))
219 (groups (cond
220 (group-name (list group-name))
221 (single-group (list single-group))
222 (t
223 (let ((group-file (merge-pathnames
224 (value netnews-group-file)
225 (user-homedir-pathname))))
226 (when (probe-file group-file)
227 (let ((res nil))
228 (with-open-file (s group-file :direction :input)
229 (loop
230 (let ((group (read-line s nil nil)))
231 (unless group (return (nreverse res)))
232 (pushnew group res)))))))))))
233 (unless (or p groups)
234 (editor-error "No groups to read. See \"Netnews Group File\" and ~
235 \"Netnews Browse\"."))
236 (when updatep (nn-assure-database-exists))
237 (nn-parse-kill-file)
238 (multiple-value-bind (stream header-stream) (streams-for-nntp)
239 (multiple-value-bind
240 (buffer-name clashp)
241 (nn-unique-headers-name (car groups))
242 (if (and (or p group-name) clashp)
243 (change-to-buffer (getstring clashp *buffer-names*))
244 (let* ((buffer (make-buffer
245 buffer-name
246 :modes '("News-Headers")
247 :modeline-fields
248 (append (value default-modeline-fields)
249 (list (modeline-field
250 :netnews-header-info)))
251 :delete-hook
252 (list #'netnews-headers-delete-hook)))
253 (nn-info (make-netnews-info
254 :current (car groups)
255 :groups groups
256 :updatep updatep
257 :headers-window (current-window)
258 :mark (copy-mark (buffer-point buffer))
259 :header-stream header-stream
260 :stream stream)))
261 (unless (or p group-name) (setf *nn-headers-buffer* buffer))
262 (when (and clashp (not (or p group-name)))
263 (message "Buffer ~S also contains headers for ~A"
264 clashp (car groups)))
265 (defhvar "Netnews Info"
266 "A structure containg the current bboard, a list of groups, a
267 book-keeping mark, a stream we get headers on, and the stream
268 on which we request articles."
269 :buffer buffer
270 :value nn-info)
271 (setf (buffer-writable buffer) nil)
272 (defhvar "Netnews Browse Buffer"
273 "This variable is the associated \"News-Browse\" buffer
274 in a \"News-Headers\" buffer created from
275 \"News-Browse\" mode."
276 :buffer buffer
277 :value browse-buf)
278 (setup-bboard (car groups) nn-info buffer from-end-p)))))))))
279
280
281 (defun nn-parse-kill-file ()
282 (let ((filename (merge-pathnames (value netnews-kill-file)
283 (user-homedir-pathname))))
284 (when (probe-file filename)
285 (with-open-file (s filename :direction :input)
286 (loop
287 (let ((kill-string (read-line s nil nil)))
288 (unless kill-string (return))
289 (pushnew kill-string *netnews-kill-strings*)))))))
290
291 ;;; NETNEWS-HEADERS-DELETE-HOOK closes the stream slots in netnews-info,
292 ;;; deletes the bookkeeping mark into buffer, sets the headers slots of any
293 ;;; associated post-info or netnews-message-info structures to nil so
294 ;;; "Netnews Go To Headers Buffer" will not land you in a buffer that does
295 ;;; not exist, and sets *nn-headers-buffer* to nil so next time we invoke
296 ;;; "Netnews" it will start over.
297 ;;;
298 (defun netnews-headers-delete-hook (buffer)
299 (let ((nn-info (variable-value 'netnews-info :buffer buffer)))
300 ;; Disassociate all message buffers.
301 ;;
302 (dolist (buf (nn-info-other-buffers nn-info))
303 (setf (nm-info-headers-buffer (variable-value 'netnews-message-info
304 :buffer buf))
305 nil))
306 (let ((message-buffer (nn-info-buffer nn-info)))
307 (when message-buffer
308 (setf (nm-info-headers-buffer (variable-value 'netnews-message-info
309 :buffer message-buffer))
310 nil)))
311 (close (nn-info-stream nn-info))
312 (close (nn-info-header-stream nn-info))
313 (delete-mark (nn-info-mark nn-info))
314 (when (eq *nn-headers-buffer* buffer)
315 (setf *nn-headers-buffer* nil))))
316
317 (defun nn-unique-headers-name (group-name)
318 (let ((original-name (concatenate 'simple-string "Netnews " group-name)))
319 (if (getstring original-name *buffer-names*)
320 (let ((name nil)
321 (number 0))
322 (loop
323 (setf name (format nil "Netnews ~A ~D" group-name (incf number)))
324 (unless (getstring name *buffer-names*)
325 (return (values name original-name)))))
326 (values original-name nil))))
327
328 ;;; NN-ASSURE-DATABASE-EXISTS does just that. If the file determined by the
329 ;;; value of "Netnews Database Filename" does not exist, then it gets
330 ;;; created.
331 ;;;
332 (defun nn-assure-database-exists ()
333 (let ((filename (merge-pathnames (value netnews-database-filename)
334 (user-homedir-pathname))))
335 (unless (probe-file filename)
336 (message "Creating netnews database file.")
337 (close (open filename :direction :output :if-does-not-exist :create)))))
338
339 (defhvar "Netnews Fetch All Headers"
340 "When NIL, all netnews reading commands will fetch headers in batches for
341 increased efficiency. Any other value will cause these commands to fetch
342 all the headers. This will take a long time if there are a lot."
343 :value nil)
344
345 (defcommand "Netnews Look at Newsgroup" (p)
346 "Prompts for the name of a newsgroup and reads it, regardless of what is
347 in and not modifying the \"Netnews Database File\"."
348 "Prompts for the name of a newsgroup and reads it, regardless of what is
349 in and not modifying the \"Netnews Database File\"."
350 (declare (ignore p))
351 (netnews-command nil (prompt-for-string :prompt "Group to look at: "
352 :help "Type the name of ~
353 the bboard you want ~
354 to look at."
355 :trim t)
356 nil nil nil))
357
358 ;;; SETUP-BBOARD is the guts of this bboard reader. It sets up a headers
359 ;;; buffer in buffer for group group-name. This consists of sending a group
360 ;;; command to both the header-stream and normal stream and then getting the
361 ;;; last message read in group-name from the database file and setting the
362 ;;; appropriate slots in the nn-info structure. The first batch of messages
363 ;;; is then requested and inserted, and room for message-ids is allocated.
364 ;;;
365 (defun setup-bboard (group-name nn-info buffer &optional from-end-p)
366 ;; Do not bind stream or header-stream because if a timeout has occurred
367 ;; before these calls are invoked, they would be bogus.
368 ;;
369 (nntp-group group-name (nn-info-stream nn-info)
370 (nn-info-header-stream nn-info))
371 (process-status-response (nn-info-stream nn-info) nn-info)
372 (let ((response (process-status-response (nn-info-header-stream nn-info)
373 nn-info)))
374 (cond ((not response)
375 (message "~A is not the name of a netnews group.~%"
376 (nn-info-current nn-info))
377 (change-to-next-group nn-info buffer))
378 (t
379 (multiple-value-bind (number first last)
380 (group-response-args response)
381 (declare (ignore first))
382 (message "Setting up ~A" group-name)
383 (let ((last-read (if (nn-info-updatep nn-info)
384 (nn-last-read-message-number group-name)))
385 (first (1+ (- last number))))
386 ;; Make sure there is at least one new message on this board.
387 (cond
388 ((and last-read (= last-read last))
389 (message "No new messages in ~A" group-name)
390 (setf (nn-info-latest nn-info) last)
391 (change-to-next-group nn-info buffer))
392 ((zerop number)
393 (message "No messages AVAILABLE in ~A" group-name)
394 (setf (nn-info-latest nn-info) last)
395 (change-to-next-group nn-info buffer))
396 (t
397 (let ((latest (if (and last-read (> last-read first))
398 (1+ last-read)
399 first)))
400 (if (or (and (= latest first)
401 (eq (value netnews-new-board-style) :from-end))
402 from-end-p)
403 (setf (nn-info-from-end-p nn-info) t))
404
405 (cond ((nn-info-from-end-p nn-info)
406 (setf (nn-info-first-visible nn-info) nil)
407 (setf (nn-info-last-visible nn-info) last))
408 (t
409 (setf (nn-info-first-visible nn-info) latest)
410 (setf (nn-info-last-visible nn-info) nil)))
411 (setf (nn-info-first nn-info) first)
412 (setf (nn-info-last nn-info) last)
413 (setf (nn-info-latest nn-info) latest))
414 ;; Request the batch before setting message-ids so they start
415 ;; coming before we need them.
416 ;;
417 (nn-request-next-batch nn-info
418 (value netnews-fetch-all-headers))
419 (let ((message-ids (nn-info-message-ids nn-info))
420 (header-cache (nn-info-header-cache nn-info))
421 (length (1+ (- last first))))
422 (multiple-value-setq
423 (message-ids header-cache)
424 (cond ((> length (nn-info-array-length nn-info))
425 (setf (nn-info-array-length nn-info) length)
426 (values (make-array length :fill-pointer 0)
427 (make-array length :fill-pointer 0
428 :initial-element nil)))
429 (message-ids
430 (when (aref header-cache 0)
431 (fill header-cache nil))
432 (setf (fill-pointer message-ids) 0)
433 (setf (fill-pointer header-cache) 0)
434 (values message-ids header-cache))
435 (t
436 (values (make-array (nn-info-array-length nn-info)
437 :fill-pointer 0)
438 (make-array (nn-info-array-length nn-info)
439 :fill-pointer 0
440 :initial-element nil)))))
441 (setf (nn-info-message-ids nn-info) message-ids)
442 (setf (nn-info-header-cache nn-info) header-cache))
443 (nn-write-headers-to-mark nn-info buffer)
444 (change-to-buffer buffer)))))))))
445
446 ;;; NN-LAST-READ-MESSAGE-NUMBER reads the last read message in group-name
447 ;;; from the value of "Netnews Database Filename". It is SETF'able and the
448 ;;; SETF method is %SET-LAST-READ-MESSAGE-NUMBER.
449 ;;;
450 (defun nn-last-read-message-number (group-name)
451 (with-open-file (s (merge-pathnames (value netnews-database-filename)
452 (user-homedir-pathname))
453 :direction :input :if-does-not-exist :error)
454 (loop
455 (let ((read-group-name (read-line s nil nil)))
456 (unless read-group-name (return nil))
457 (when (string-equal read-group-name group-name)
458 (let ((last-read (read-line s nil nil)))
459 (if last-read
460 (return (parse-integer last-read))
461 (error "Should have been a message number ~
462 following ~S in database file."
463 group-name))))))))
464
465 (defun %set-nn-last-read-message-number (group-name new-value)
466 (with-open-file (s (merge-pathnames (value netnews-database-filename)
467 (user-homedir-pathname))
468 :direction :io :if-does-not-exist :error
469 :if-exists :overwrite)
470 (unless (loop
471 (let ((read-group-name (read-line s nil nil)))
472 (unless read-group-name (return nil))
473 (when (string-equal read-group-name group-name)
474 ;; File descriptor streams do not do the right thing with
475 ;; :io/:overwrite streams, so work around it by setting it
476 ;; explicitly.
477 ;;
478 (file-position s (file-position s))
479 ;; Justify the number so that if the number of digits in it
480 ;; changes, we won't overwrite the next group name.
481 ;;
482 (format s "~14D~%" new-value)
483 (return t))))
484 (write-line group-name s)
485 (format s "~14D~%" new-value))))
486
487 (defsetf nn-last-read-message-number %set-nn-last-read-message-number)
488
489 (defconstant nntp-eof ".
490 "
491 "NNTP marks the end of a textual response with this. NNTP also recognizes
492 this as the end of a post.")
493
494 ;;; This macro binds a variable to each successive line of input from NNTP
495 ;;; and exits when it sees the NNTP end-of-file-marker, a period by itself on
496 ;;; a line.
497 ;;;
498 (defmacro with-input-from-nntp ((var stream) &body body)
499 "Body is executed with var bound to successive lines of input from nntp.
500 Exits at the end of a response, returning whatever the last execution of
501 Body returns, or nil if there was no input.
502 Take note: this is only to be used for textual responses. Status responses
503 are of an entirely different nature."
504 (let ((return-value (gensym)))
505 `(let ((,return-value nil)
506 (,var ""))
507 (declare (simple-string ,var))
508 (loop
509 (setf ,var (read-line ,stream))
510 (when (string= ,var nntp-eof) (return ,return-value))
511 (setf ,return-value (progn ,@body))))))
512
513
514 ;;; Writing the date, from, and subject fields to a mark.
515
516 (defhvar "Netnews Before Date Field Pad"
517 "How many spaces should be inserted before the date in Netnews. The default
518 is 1."
519 :value 1)
520
521 (defhvar "Netnews Date Field Length"
522 "How long the date field should be in \"News-Headers\" buffers. The
523 default is 6"
524 :value 6)
525
526 (defhvar "Netnews Line Field Length"
527 "How long the line field should be in \"News-Headers\" buffers. The
528 default is 3"
529 :value 3)
530
531 (defhvar "Netnews From Field Length"
532 "How long the from field should be in \"News-Headers\" buffers. The
533 default is 20."
534 :value 20)
535
536 (defhvar "Netnews Subject Field Length"
537 "How long the subject field should be in \"News-Headers\" buffers. The
538 default is 43."
539 :value 43)
540
541 (defhvar "Netnews Field Padding"
542 "How many spaces should be left between the netnews date, from, lines, and
543 subject fields. The default is 2."
544 :value 2)
545
546 ;;;
547 (defconstant netnews-space-string
548 (make-array 70 :element-type 'string-char :initial-element #\space))
549 ;;;
550 (defconstant missing-message (cons nil nil)
551 "Use this as a marker so nn-write-headers-to-mark doesn't try to insert
552 a message that is not really there.")
553
554 ;;; NN-CACHE-HEADER-INFO stashes all header information into an array for
555 ;;; later use.
556 ;;;
557 (defun nn-cache-header-info (nn-info howmany use-header-stream-p)
558 (let* ((cache (nn-info-header-cache nn-info))
559 (message-ids (nn-info-message-ids nn-info))
560 (stream (if use-header-stream-p
561 (nn-info-header-stream nn-info)
562 (nn-info-stream nn-info)))
563 (from-end-p (nn-info-from-end-p nn-info))
564 (old-count 0))
565 (declare (fixnum old-count))
566 (when from-end-p
567 (setf old-count (length message-ids))
568 (do ((i (length message-ids) (1- i)))
569 ((minusp i) nil)
570 (setf (aref message-ids (+ i howmany)) (aref message-ids i)))
571 (setf (fill-pointer message-ids) 0))
572 (let ((missing-message-count 0)
573 (offset (nn-info-first nn-info)))
574 (dotimes (i howmany)
575 (let ((response (process-status-response stream)))
576 (if response
577 (let* ((id (head-response-args response))
578 (index (- id offset)))
579 (vector-push id message-ids)
580 (with-input-from-nntp (string stream)
581 (let ((colonpos (position #\: string)))
582 (when colonpos
583 (push (cons (subseq string 0 colonpos)
584 (subseq string
585 (+ colonpos 2)))
586 (aref cache index))))))
587 (incf missing-message-count))))
588 (when from-end-p
589 (when (plusp missing-message-count)
590 (dotimes (i old-count)
591 (setf (aref message-ids (- (+ i howmany) missing-message-count))
592 (aref message-ids (+ i howmany)))))
593 (setf (fill-pointer message-ids)
594 (- (+ old-count howmany) missing-message-count))))))
595
596 (defvar netnews-field-na "NA"
597 "This string gets inserted when NNTP doesn't find a field.")
598
599 (defvar netnews-field-na-length (length netnews-field-na)
600 "The length of netnews-field-na")
601
602 (defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p
603 out-of-order-p)
604 (let* ((howmany (nn-info-batch-count nn-info))
605 (from-end-p (nn-info-from-end-p nn-info))
606 (cache (nn-info-header-cache nn-info))
607 (old-point (copy-mark (buffer-point buffer) (if from-end-p
608 :left-inserting
609 :right-inserting)))
610 (messages-waiting (nn-info-messages-waiting nn-info))
611 (mark (nn-info-mark nn-info)))
612 (unless messages-waiting
613 (return-from nn-write-headers-to-mark nil))
614 (if from-end-p
615 (buffer-start mark)
616 (buffer-end mark))
617 (nn-cache-header-info nn-info howmany (not out-of-order-p))
618 (with-writable-buffer (buffer)
619 (with-mark ((check-point mark :right-inserting))
620 (macrolet ((mark-to-pos (mark pos)
621 `(insert-string ,mark netnews-space-string
622 0 (- ,pos (mark-column ,mark))))
623 (insert-field (mark field-string field-length)
624 `(if ,field-string
625 (insert-string ,mark ,field-string
626 0 (min ,field-length
627 (1- (length ,field-string))))
628 (insert-string ,mark netnews-field-na
629 0 (min ,field-length
630 netnews-field-na-length)))))
631 (let* ((line-start (+ (value netnews-before-date-field-pad)
632 (value netnews-date-field-length)
633 (value netnews-field-padding)))
634 (from-start (+ line-start
635 (value netnews-line-field-length)
636 (value netnews-field-padding)))
637 (subject-start (+ from-start
638 (value netnews-from-field-length)
639 (value netnews-field-padding)))
640 (start (- messages-waiting (nn-info-first nn-info)))
641 (end (1- (+ start howmany))))
642 (do ((i start (1+ i)))
643 ((> i end))
644 (let ((assoc-list (aref cache i)))
645 (unless (null assoc-list)
646 (insert-string mark netnews-space-string
647 0 (value netnews-before-date-field-pad))
648 (let* ((date-field (cdr (assoc "date" assoc-list
649 :test #'string-equal)))
650 (universal-date (if date-field
651 (ext:parse-time date-field
652 :end (1- (length date-field))))))
653 (insert-field
654 mark
655 (if universal-date
656 (string-capitalize
657 (format-universal-time nil universal-date
658 :style :government
659 :print-weekday nil))
660 date-field)
661 (value netnews-date-field-length)))
662 (mark-to-pos mark line-start)
663 (insert-field mark (cdr (assoc "lines" assoc-list
664 :test #'string-equal))
665 (value netnews-line-field-length))
666 (mark-to-pos mark from-start)
667 (insert-field mark (cdr (assoc "from" assoc-list
668 :test #'string-equal))
669 (value netnews-from-field-length))
670 (mark-to-pos mark subject-start)
671 (insert-field mark (cdr (assoc "subject" assoc-list
672 :test #'string-equal))
673 (value netnews-subject-field-length))
674 (insert-character mark #\newline))))))
675 (cond (out-of-order-p
676 (setf (nn-info-first-visible nn-info) messages-waiting))
677 (t
678 (if (nn-info-from-end-p nn-info)
679 (setf (nn-info-first-visible nn-info) messages-waiting)
680 (setf (nn-info-last-visible nn-info) (1- (+ messages-waiting
681 howmany))))
682 (if (nn-info-last-batch-p nn-info)
683 (setf (nn-info-messages-waiting nn-info) nil)
684 (nn-request-next-batch nn-info fetch-rest-p))))
685 (when (mark= mark check-point)
686 (message "All messages in last batch were missing, getting more."))
687 (move-mark (buffer-point buffer) old-point)
688 (delete-mark old-point)))))
689
690 ;;; NN-MAYBE-GET-MORE-HEADERS gets more headers if the point of the headers
691 ;;; buffer is on an empty line and there are some. Returns whether it got more
692 ;;; headers, i.e., if it is time to go on to the next bboard.
693 ;;;
694 (defun nn-maybe-get-more-headers (nn-info)
695 (let ((headers-buffer (line-buffer (mark-line (nn-info-mark nn-info)))))
696 (when (empty-line-p (buffer-point headers-buffer))
697 (cond ((and (nn-info-messages-waiting nn-info)
698 (not (nn-info-from-end-p nn-info)))
699 (nn-write-headers-to-mark nn-info headers-buffer)
700 t)
701 (t :go-on)))))
702
703 (defhvar "Netnews Batch Count"
704 "Determines how many headers the Netnews facility will fetch at a time.
705 The default is 50."
706 :value 50)
707
708 ;;; NN-REQUEST-NEXT-BATCH requests the next batch of messages in a group.
709 ;;; For safety, don't do anything if there is no next-batch start.
710 ;;;
711 (defun nn-request-next-batch (nn-info &optional fetch-rest-p)
712 (if (nn-info-from-end-p nn-info)
713 (nn-request-backward nn-info fetch-rest-p)
714 (nn-request-forward nn-info fetch-rest-p)))
715
716 (defun nn-request-forward (nn-info fetch-rest-p)
717 (let* ((last-visible (nn-info-last-visible nn-info))
718 (last (nn-info-last nn-info))
719 (batch-start (if last-visible
720 (1+ (nn-info-last-visible nn-info))
721 (nn-info-latest nn-info)))
722 (header-stream (nn-info-header-stream nn-info))
723 (batch-end (if fetch-rest-p
724 last
725 (1- (+ batch-start (value netnews-batch-count))))))
726 ;; If this is the last batch, adjust batch-end appropriately.
727 ;;
728 (when (>= batch-end last)
729 (setf batch-end last)
730 (setf (nn-info-last-batch-p nn-info) t))
731 (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start)))
732 (setf (nn-info-messages-waiting nn-info) batch-start)
733 (nn-send-many-head-requests header-stream batch-start batch-end nil)))
734
735 (defun nn-request-backward (nn-info fetch-rest-p
736 &optional (use-header-stream-p t))
737 (let* ((first-visible (nn-info-first-visible nn-info))
738 (batch-end (if first-visible
739 (1- (nn-info-first-visible nn-info))
740 (nn-info-last nn-info)))
741 (stream (if use-header-stream-p
742 (nn-info-header-stream nn-info)
743 (nn-info-stream nn-info)))
744 (first (nn-info-first nn-info))
745 (batch-start (if fetch-rest-p
746 first
747 (1+ (- batch-end (value netnews-batch-count))))))
748 ;; If this is the last batch, adjust batch-end appropriately.
749 ;;
750 (when (<= batch-start first)
751 (setf batch-start first)
752 (setf (nn-info-last-batch-p nn-info) t))
753 (setf (nn-info-batch-count nn-info) (1+ (- batch-end batch-start)))
754 (setf (nn-info-messages-waiting nn-info) batch-start)
755 (nn-send-many-head-requests stream batch-start batch-end
756 (not use-header-stream-p))))
757
758 ;;; NN-REQUEST-OUT-OF-ORDER is called when the user is reading a board normally
759 ;;; and decides he wants to see some messages before the first one visible.
760 ;;; To accomplish this without disrupting the normal flow of things, we fool
761 ;;; ourselves into thinking we are reading the board from the end, remembering
762 ;;; several slots that could be modified in requesting thesse messages.
763 ;;; When we are done, return state to what it was for reading a board forward.
764 ;;;
765 (defun nn-request-out-of-order (nn-info headers-buffer)
766 (let ((messages-waiting (nn-info-messages-waiting nn-info))
767 (batch-count (nn-info-batch-count nn-info))
768 (last-batch-p (nn-info-last-batch-p nn-info)))
769 (nn-request-backward nn-info nil nil)
770 (setf (nn-info-from-end-p nn-info) t)
771 (nn-write-headers-to-mark nn-info headers-buffer nil t)
772 (setf (nn-info-messages-waiting nn-info) messages-waiting)
773 (setf (nn-info-batch-count nn-info) batch-count)
774 (setf (nn-info-last-batch-p nn-info) last-batch-p)
775 (setf (nn-info-from-end-p nn-info) nil)))
776
777 (proclaim '(special *nn-last-command-issued*))
778
779 (defun nn-send-many-head-requests (stream first last out-of-order-p)
780 (do ((i first (1+ i)))
781 ((> i last))
782 (nntp-head i stream))
783 (setf *nn-last-command-issued*
784 (list (if out-of-order-p :out-of-order :header)
785 first last out-of-order-p)))
786
787 (defvar nn-minimum-header-batch-count 30
788 "The minimum number of headers to fetch at any given time.")
789
790
791
792 ;;;; "News-Message" mode.
793
794 (defmode "News-Message" :major-p t)
795
796
797
798 ;;;; Commands for viewing articles.
799
800 (defcommand "Netnews Show Article" (p)
801 "Show the message the point is on. If it is the same message that is
802 already in the message buffer and \"Netnews Read Style\" is :multiple,
803 then just scroll the window down prefix argument lines"
804 "Show the message the point is on. If it is the same message that is
805 already in the message buffer and \"Netnews Read Style\" is :multiple,
806 then just scroll the window down prefix argument lines"
807 (nn-show-article (value netnews-info) p))
808
809 (defcommand "Netnews Next Article" (p)
810 "Show the next article in the current newsgroup."
811 "Shows the article on the line preceeding the point in the headers buffer."
812 (declare (ignore p))
813 (let* ((what-next (netnews-next-line-command nil (nn-get-headers-buffer))))
814 (when (and (not (eq what-next :done))
815 (or (eq what-next t)
816 (eq (value netnews-last-header-style) :next-article)))
817 ;; Reget the headers buffer because the call to netnews-next-line-command
818 ;; might have moved us into a different buffer.
819 ;;
820 (nn-show-article (variable-value 'netnews-info
821 :buffer (nn-get-headers-buffer))
822 t))))
823
824 (defcommand "Netnews Previous Article" (p)
825 "Show the previous article in the current newsgroup."
826 "Shows the article on the line after the point in the headers buffer."
827 (declare (ignore p))
828 (let ((buffer (nn-get-headers-buffer)))
829 (netnews-previous-line-command nil buffer)
830 (nn-show-article (variable-value 'netnews-info :buffer buffer) t)))
831
832 ;;; NN-SHOW-ARTICLE checks first to see if we need to get more headers. If
833 ;;; NN-MAYBE-GET-MORE-HEADERS returns nil then don't do anything because we
834 ;;; changed to the next group. Then see if the message the user has
835 ;;; requested is already in the message buffer. If the it isn't, put it
836 ;;; there. If it is, and maybe-scroll-down is t, then scroll the window
837 ;;; down p lines in :multiple mode, or just change to the buffer in :single
838 ;;; mode. I use scroll-window down becuase this function is called by
839 ;;; "Netnews Show Article", "Netnews Next Article", and "Netnews Previous
840 ;;; Article". It doesn't make sense to scroll the window down if the guy
841 ;;; just read a message, moved the point up one line and invoked "Netnews
842 ;;; Next Article". He expects to see the article again, not the second
843 ;;; page of it. Also check to make sure there is a message under the
844 ;;; point. If there is not, then get some more headers. If there are no
845 ;;; more headers, then go on to the next board. I can read and write. Hi
846 ;;; Bill. Are you having fun grocking my code? Hope so -- Dude. Nothing
847 ;;; like stream of consciousness is there? Come to think of it, this is
848 ;;; kind of like recursive stream of conscious because I'm writing down my
849 ;;; stream of conscious which is about my stream of conscious. I think I'm
850 ;;; insane. In fact I know I am.
851 ;;;
852 (defun nn-show-article (nn-info dont-scroll-down &optional p)
853 (let ((headers-buffer (nn-get-headers-buffer))
854 (message-buffer (nn-info-buffer nn-info)))
855 (cond
856 ((eq (nn-maybe-get-more-headers nn-info) :go-on)
857 (case (value netnews-last-header-style)
858 (:this-headers (change-to-buffer headers-buffer)
859 (buffer-start (buffer-point headers-buffer))
860 (editor-error "Last header."))
861 (:next-headers (change-to-next-group nn-info headers-buffer))
862 (:next-article (change-to-next-group nn-info headers-buffer)
863 (netnews-show-article-command nil))))
864 (t
865 (cond ((and (not dont-scroll-down)
866 (= (nn-info-current-displayed-message nn-info)
867 (array-element-from-mark (buffer-point headers-buffer)
868 (nn-info-message-ids nn-info))))
869 (ecase (value netnews-read-style)
870 (:single (buffer-start (buffer-point message-buffer))
871 (change-to-buffer message-buffer))
872 (:multiple
873 (multiple-value-bind
874 (headers-window message-window newp)
875 (nn-assure-multi-windows nn-info)
876 (nn-put-buffers-in-windows headers-buffer message-buffer
877 headers-window message-window
878 :headers)
879 ;; If both windows were visible to start with, just scroll
880 ;; down. If they weren't, then show the message over
881 ;; again.
882 ;;
883 (cond (newp (buffer-start (buffer-point message-buffer))
884 (buffer-start (window-point message-window)))
885 (t (netnews-message-scroll-down-command
886 p message-buffer message-window)))))))
887 (t
888 (nn-put-article-in-buffer nn-info headers-buffer)
889 (setf message-buffer (nn-info-buffer nn-info))
890 (multiple-value-bind
891 (headers-window message-window)
892 (ecase (value netnews-read-style) ; Only need windows in
893 (:single (values nil nil)) ; :multiple mode.
894 (:multiple (nn-assure-multi-windows nn-info)))
895 (ecase (value netnews-read-style)
896 (:multiple
897 ;; When there is only one window displaying the headers
898 ;; buffer, move the window point of that buffer to the
899 ;; buffer-point.
900 (when (= (length (buffer-windows headers-buffer)) 1)
901 (move-mark (window-point headers-window)
902 (buffer-point headers-buffer)))
903 (buffer-start (window-point message-window))
904 (nn-put-buffers-in-windows headers-buffer message-buffer
905 headers-window message-window
906 :headers))
907 (:single (change-to-buffer message-buffer))))))))))
908
909 (defcommand "Netnews Message Punt" (p)
910 "Destroy this message buffer, and pop back to the associated headers buffer."
911 "Destroy this message buffer, and pop back to the associated headers buffer."
912 (declare (ignore p))
913 (unless (hemlock-bound-p 'netnews-message-info)
914 (editor-error "Not in a News-Message Buffer"))
915 (let ((message-buffer (current-buffer)))
916 (change-to-buffer (nn-get-headers-buffer))
917 (delete-buffer-if-possible message-buffer)))
918
919 (defhvar "Netnews Message Header Fields"
920 "When NIL, the default, all available fields are displayed in the header
921 of a message. Otherwise, this variable should containt a list of fields
922 that should be included in the message header when a message is
923 displayed. Any string name is acceptable. Fields that do not exist are
924 ignored. If an element of this list is an atom, then it should be the
925 string name of a field. If it is a cons, then the car should be the
926 string name of a field, and the cdr should be the length to which this
927 field should be limited."
928 :value nil)
929
930 ;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the
931 ;;; associated message buffer if it is not there already. Uses value of
932 ;;; "Netnews Message Header Fields" to determine what fields should appear
933 ;;; in the message header. Returns the number of the article under the
934 ;;; point.
935 ;;;
936 (defun nn-put-article-in-buffer (nn-info headers-buffer)
937 (let ((stream (nn-info-stream nn-info))
938 (article-number (array-element-from-mark
939 (buffer-point headers-buffer)
940 (nn-info-message-ids nn-info)))
941 (message-buffer (nn-get-message-buffer nn-info)))
942 (setf (nm-info-message-number (variable-value 'netnews-message-info
943 :buffer message-buffer))
944 (1+ (- article-number (nn-info-first nn-info))))
945 (cond ((= (nn-info-current-displayed-message nn-info) article-number)
946 (buffer-start (buffer-point message-buffer)))
947 (t
948 ;; Request article as soon as possible to avoid waiting for reply.
949 ;;
950 (nntp-body article-number stream)
951 (setf (nn-info-current-displayed-message nn-info) article-number)
952 (process-status-response stream nn-info)
953 (with-writable-buffer (message-buffer)
954 (let ((point (buffer-point message-buffer))
955 (info (aref (nn-info-header-cache nn-info)
956 (- article-number (nn-info-first nn-info))))
957 (message-fields (value netnews-message-header-fields))
958 key field-length)
959 (cond (message-fields
960 (dolist (ele message-fields)
961 (etypecase ele
962 (atom (setf key ele field-length nil))
963 (cons (setf key (car ele) field-length (cdr ele))))
964 (let ((field-string (cdr (assoc key info
965 :test #'string-equal))))
966 (when field-string
967 (insert-string point (string-capitalize key))
968 (insert-string point ": ")
969 (insert-string point field-string
970 0
971 (max
972 (if field-length
973 (min field-length
974 (1- (length field-string)))
975 (1- (length field-string)))
976 0))
977 (insert-character point #\newline)))))
978 (t
979 (dolist (ele info)
980 (insert-string point (string-capitalize (car ele)))
981 (insert-string point ": ")
982 (insert-string point (cdr ele)
983 0 (max 0 (1- (length (cdr ele)))))
984 (insert-character point #\newline))))
985 (insert-character point #\newline)
986 (nntp-insert-textual-response point (nn-info-stream nn-info))))
987 (buffer-start (buffer-point message-buffer))
988 (when (> article-number (nn-info-latest nn-info))
989 (setf (nn-info-latest nn-info) article-number))))
990 article-number))
991
992 ;;; NN-PUT-BUFFERS-IN-WINDOWS makes sure the message buffer goes in the message
993 ;;; window and the headers buffer in the headers window. If which-current
994 ;;; is :headers, the headers buffer/window will be made current, if it is
995 ;;; :message, the message buffer/window will be made current.
996 ;;;
997 (defun nn-put-buffers-in-windows (headers-buffer message-buffer headers-window
998 message-window which-current)
999 (setf (window-buffer message-window) message-buffer
1000 (window-buffer headers-window) headers-buffer)
1001 (setf (current-window) (ecase which-current
1002 (:headers headers-window)
1003 (:message message-window))
1004 (current-buffer) (case which-current
1005 (:headers headers-buffer)
1006 (:message message-buffer))))
1007
1008 (defhvar "Netnews Headers Proportion"
1009 "Determines how much of the current window will display headers when
1010 \"Netnews Read Style\" is :multiple. Defaults to .25"
1011 :value .25)
1012
1013 (defun nn-assure-multi-windows (nn-info)
1014 (let ((newp nil))
1015 (unless (and (member (nn-info-message-window nn-info) *window-list*)
1016 (member (nn-info-headers-window nn-info) *window-list*))
1017 (setf newp t)
1018 (setf (nn-info-message-window nn-info) (current-window)
1019 (nn-info-headers-window nn-info)
1020 (make-window (buffer-start-mark (nn-get-headers-buffer))
1021 :proportion (value netnews-headers-proportion))))
1022 (values (nn-info-headers-window nn-info)
1023 (nn-info-message-window nn-info)
1024 newp)))
1025
1026 ;;; NN-GET-MESSAGE-BUFFER returns the message buffer for an nn-info structure.
1027 ;;; If there is not one, this function makes it and sets the slot in nn-info.
1028 ;;;
1029 (defun nn-get-message-buffer (nn-info)
1030 (let* ((message-buffer (nn-info-buffer nn-info))
1031 (nm-info (if message-buffer
1032 (variable-value 'netnews-message-info
1033 :buffer message-buffer))))
1034 (cond ((and message-buffer (not (nm-info-keep-p nm-info)))
1035 (with-writable-buffer (message-buffer)
1036 (delete-region (buffer-region message-buffer)))
1037 message-buffer)
1038 (t
1039 (let ((buf (make-buffer (nn-unique-message-buffer-name
1040 (nn-info-current nn-info))
1041 :modeline-fields
1042 (append (value default-modeline-fields)
1043 (list (modeline-field
1044 :netnews-message)))
1045 :modes '("News-Message")
1046 :delete-hook
1047 (list #'nn-message-buffer-delete-hook))))
1048 (setf (nn-info-buffer nn-info) buf)
1049 (defhvar "Netnews Message Info"
1050 "Structure that keeps track of buffers in \"News-Message\"
1051 mode."
1052 :value (make-netnews-message-info
1053 :headers-buffer (current-buffer))
1054 :buffer buf)
1055 buf)))))
1056
1057 ;;; The usual. Clean everything up.
1058 ;;;
1059 (defun nn-message-buffer-delete-hook (buffer)
1060 (let* ((headers-buffer (nm-info-headers-buffer
1061 (variable-value 'netnews-message-info
1062 :buffer buffer)))
1063 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1064 (nm-info (variable-value 'netnews-message-info :buffer buffer)))
1065 (setf (nn-info-buffer nn-info) nil)
1066 (setf (nn-info-current-displayed-message nn-info) -1)
1067 (let ((post-buffer (nm-info-post-buffer nm-info)))
1068 (when post-buffer
1069 (setf (post-info-message-buffer (variable-value
1070 'post-info :buffer post-buffer))
1071 nil)))))
1072
1073
1074 ;;; NN-UNIQUE-MESSAGE-BUFFER-NAME likes to have a simple name, i.e.
1075 ;;; "Netnews Message for rec.music.synth". When there is already a buffer
1076 ;;; by this name, however, we start counting until the name is unique.
1077 ;;;
1078 (defun nn-unique-message-buffer-name (group)
1079 (let ((name (concatenate 'simple-string "Netnews Message for " group))
1080 (number 0))
1081 (loop
1082 (unless (getstring name *buffer-names*) (return name))
1083 (setf name (format nil "Netnews Message ~D" number))
1084 (incf number))))
1085
1086 ;;; INSERT-TEXTUAL-RESPONSE inserts a textual response from nntp at mark.
1087 ;;;
1088 (defun nntp-insert-textual-response (mark stream)
1089 (with-input-from-nntp (string stream)
1090 (insert-string mark string 0 (1- (length string)))
1091 (insert-character mark #\newline)))
1092
1093 ;;; NN-GET-HEADERS-BUFFER returns the headers buffer if we are in a message or
1094 ;;; headers buffer.
1095 ;;;
1096 (defun nn-get-headers-buffer ()
1097 (cond ((hemlock-bound-p 'netnews-info)
1098 (current-buffer))
1099 ((hemlock-bound-p 'netnews-message-info)
1100 (nm-info-headers-buffer (value netnews-message-info)))
1101 ((hemlock-bound-p 'post-info)
1102 (post-info-headers-buffer (value post-info)))
1103 (t nil)))
1104
1105
1106 (defcommand "Netnews Previous Line" (p &optional
1107 (headers-buffer (current-buffer)))
1108 "Moves the point to the last header before the point that is not in your
1109 kill file. If you move off the end of the buffer and there are more
1110 headers, then get them. Otherwise go on to the next group in \"Netnews
1111 Groups\"."
1112 "Moves the point to the last header before the point that is not in your
1113 kill file. If you move off the end of the buffer and there are more
1114 headers, then get them. Otherwise go on to the next group in \"Netnews
1115 Groups\"."
1116 (declare (ignore p))
1117 (let ((point (buffer-point headers-buffer))
1118 (nn-info (variable-value 'netnews-info :buffer headers-buffer)))
1119 (with-mark ((original-position point)
1120 (start point)
1121 (end point))
1122 (loop
1123 (unless (line-offset point -1)
1124 (cond ((and (nn-info-from-end-p nn-info)
1125 (nn-info-messages-waiting nn-info))
1126 (nn-write-headers-to-mark nn-info headers-buffer)
1127 (netnews-previous-line-command nil headers-buffer))
1128 (t
1129 (cond ((= (nn-info-first-visible nn-info)
1130 (nn-info-first nn-info))
1131 (move-mark point original-position)
1132 (editor-error "No previous unKilled headers."))
1133 (t
1134 (message "Requesting backward...")
1135 (nn-request-out-of-order nn-info headers-buffer)
1136 (netnews-previous-line-command nil headers-buffer))))))
1137 (line-start (move-mark start point))
1138 (character-offset (move-mark end start) 1)
1139 (unless (string= (region-to-string (region start end)) "K")
1140 (return))))))
1141
1142 (defhvar "Netnews Last Header Style"
1143 "When you read the last message in a newsgroup, this variable determines
1144 what will happen next. Takes one of three values: :this-headers,
1145 :next-headers, or :next-article. :this-headers, the default means put me
1146 in the headers buffer for this newsgroup. :next-headers means go to the
1147 next newsgroup and put me in that headers buffer. :next-article means go
1148 on to the next newsgroup and show me the first unread article."
1149 :value :next-headers)
1150
1151 (defcommand "Netnews Next Line"
1152 (p &optional (headers-buffer (current-buffer)))
1153 "Moves the point to the next header that is not in your kill file. If you
1154 move off the end of the buffer and there are more headers, then get them.
1155 Otherwise go on to the next group in \"Netnews Groups\"."
1156 "Moves the point to the next header that is not in your kill file. If you
1157 move off the end of the buffer and there are more headers, then get them.
1158 Otherwise go on to the next group in \"Netnews Groups\".
1159 Returns nil if we have gone on to the next bboard, :done if there are no
1160 more boards to read, or T if everything is normal."
1161 (declare (ignore p))
1162 (let* ((nn-info (variable-value 'netnews-info :buffer headers-buffer))
1163 (point (buffer-point headers-buffer)))
1164 (with-mark ((start point)
1165 (end point))
1166 (loop
1167 (line-offset point 1)
1168 (cond ((eq (nn-maybe-get-more-headers nn-info) :go-on)
1169 (cond ((eq (value netnews-last-header-style) :this-headers)
1170 (let ((headers-buffer (nn-get-headers-buffer)))
1171 (change-to-buffer headers-buffer))
1172 (editor-error "Last header."))
1173 (t
1174 (return (change-to-next-group nn-info headers-buffer)))))
1175 (t
1176 (line-start (move-mark start point))
1177 (character-offset (move-mark end start) 1)
1178 (unless (string= (region-to-string (region start end)) "K")
1179 (return t))))))))
1180
1181 (defcommand "Netnews Headers Scroll Window Up" (p)
1182 "Does what \"Scroll Window Up\" does, but fetches backward when the point
1183 reaches the start of the headers buffer."
1184 "Does what \"Scroll Window Up\" does, but fetches backward when the point
1185 reaches the start of the headers buffer."
1186 (scroll-window-up-command p)
1187 (let ((headers-buffer (current-buffer))
1188 (nn-info (value netnews-info)))
1189 (when (and (displayed-p (buffer-start-mark headers-buffer)
1190 (current-window))
1191 (not (= (nn-info-first nn-info)
1192 (nn-info-first-visible nn-info))))
1193 (buffer-start (current-point))
1194 (netnews-previous-line-command nil))))
1195
1196 (defcommand "Netnews Headers Scroll Window Down" (p)
1197 "Does what \"Scroll Window Down\" does, but when the point reaches the end of
1198 the headers buffer, pending headers are inserted."
1199 "Does what \"Scroll Window Down\" does, but when the point reaches the end of
1200 the headers buffer, pending headers are inserted."
1201 (scroll-window-down-command p)
1202 (let ((headers-buffer (current-buffer))
1203 (nn-info (value netnews-info)))
1204 (when (and (displayed-p (buffer-end-mark headers-buffer) (current-window))
1205 (not (= (nn-info-last nn-info) (nn-info-last-visible nn-info))))
1206 (buffer-end (current-point))
1207 (netnews-next-line-command nil))))
1208
1209 (defcommand "Netnews Message Keep Buffer" (p)
1210 "Specifies that you don't want Hemlock to reuse the current message buffer."
1211 "Specifies that you don't want Hemlock to reuse the current message buffer."
1212 (declare (ignore p))
1213 (unless (hemlock-bound-p 'netnews-message-info)
1214 (editor-error "Not in a News-Message buffer."))
1215 (setf (nm-info-keep-p (value netnews-message-info)) t))
1216
1217 (defcommand "Netnews Message Select Headers Buffer" (p)
1218 "From \"Message Mode\", switch to the associated headers buffer."
1219 "From \"Message Mode\", switch to the associated headers buffer."
1220 (declare (ignore p))
1221 (unless (hemlock-bound-p 'netnews-message-info)
1222 (editor-error "Not in a message buffer."))
1223 (let ((headers-buffer (nm-info-headers-buffer (value netnews-message-info))))
1224 (unless headers-buffer (editor-error "Headers buffer has been deleted"))
1225 (change-to-buffer headers-buffer)))
1226
1227 (defcommand "Netnews Message Select Post Buffer" (p)
1228 "Change to the associated \"Post\" buffer (if there is one) from a
1229 \"News-Message\" buffer."
1230 "Change to the associated \"Post\" buffer (if there is one) from a
1231 \"News-Message\" buffer."
1232 (declare (ignore p))
1233 (unless (hemlock-bound-p 'netnews-message-info)
1234 (editor-error "Not in a News-Message buffer."))
1235 (let ((post-buffer (nm-info-post-buffer (value netnews-message-info))))
1236 (unless post-buffer (editor-error "No associated post buffer."))
1237 (change-to-buffer post-buffer)))
1238
1239 (defcommand "Netnews Message Select Draft Buffer" (p)
1240 "Change to the associated \"Draft\" buffer (if there is one) from a
1241 \"News-Message\" buffer."
1242 "Change to the associated \"Draft\" buffer (if there is one) from a
1243 \"News-Message\" buffer."
1244 (declare (ignore p))
1245 (unless (hemlock-bound-p 'netnews-message-info)
1246 (editor-error "Not in a News-Message buffer."))
1247 (let ((draft-buffer (nm-info-draft-buffer (value netnews-message-info))))
1248 (unless draft-buffer (editor-error "No associated post buffer."))
1249 (change-to-buffer draft-buffer)))
1250
1251 (defcommand "Netnews Select Message Buffer" (p)
1252 "Change to the associated message buffer (if there is one) in \"Post\" or
1253 \"News-Headers\" modes."
1254 "Change to the associated message buffer (if there is one) in \"Post\" or
1255 \"News-Headers\" modes."
1256 (declare (ignore p))
1257 (let* ((cbuf (current-buffer))
1258 (mbuf (cond ((hemlock-bound-p 'post-info :buffer cbuf)
1259 (post-info-message-buffer (value post-info)))
1260 ((hemlock-bound-p 'netnews-info :buffer cbuf)
1261 (nn-info-buffer (value netnews-info)))
1262 (t
1263 (editor-error "Not in a \"Post\" or \"News-Headers\" ~
1264 buffer.")))))
1265 (unless mbuf (editor-error "No assocated message buffer."))
1266 (change-to-buffer mbuf)))
1267
1268 ;;; CHANGE-TO-NEXT-GROUP deletes nn-info's headers buffer region and sets
1269 ;;; up the next group in that buffer. If there are no more groups to read,
1270 ;;; exits gracefully.
1271 ;;;
1272 (defun change-to-next-group (nn-info headers-buffer)
1273 (when (nn-info-updatep nn-info)
1274 (nn-update-database-file (nn-info-latest nn-info)
1275 (nn-info-current nn-info)))
1276 (let ((next-group (cadr (member (nn-info-current nn-info)
1277 (nn-info-groups nn-info) :test #'string=))))
1278 (cond (next-group
1279 (message "Going on to ~A" next-group)
1280 (force-output *echo-area-stream*)
1281 (let ((message-buffer (nn-info-buffer nn-info)))
1282 (when message-buffer
1283 (setf (buffer-name message-buffer)
1284 (nn-unique-message-buffer-name next-group))))
1285 (setf (buffer-name headers-buffer)
1286 (nn-unique-headers-name next-group))
1287 (setf (nn-info-current nn-info) next-group)
1288 (with-writable-buffer (headers-buffer)
1289 (delete-region (buffer-region headers-buffer)))
1290 (setup-bboard next-group nn-info headers-buffer)
1291 nil)
1292 (t
1293 (if (eq headers-buffer *nn-headers-buffer*)
1294 (message "This was your last bboard. Exiting Netnews.")
1295 (message "Done with ~A. Exiting Netnews."
1296 (nn-info-current nn-info)))
1297 (netnews-exit-command nil t headers-buffer)
1298 :done))))
1299
1300 (defun nn-update-database-file (latest group-name)
1301 (when latest (setf (nn-last-read-message-number group-name) latest)))
1302
1303
1304
1305 ;;;; More commands.
1306
1307 (defhvar "Netnews Scroll Show Next Message"
1308 "When non-nil, the default, Hemlock will show the next message in a group
1309 when you scroll off the end of one. Otherwise Hemlock will editor error
1310 that you are at the end of the buffer."
1311 :value T)
1312
1313 (defcommand "Netnews Message Scroll Down" (p &optional (buffer (current-buffer))
1314 (window (current-window)))
1315 "Scrolls the current window down one screenful, checking to see if we need
1316 to get the next message."
1317 "Scrolls the current window down one screenful, checking to see if we need
1318 to get the next message."
1319 (if (displayed-p (buffer-end-mark buffer) window)
1320 (if (value netnews-scroll-show-next-message)
1321 (netnews-next-article-command nil)
1322 (editor-error "At end of buffer."))
1323 (scroll-window-down-command p window)))
1324
1325 (defcommand "Netnews Go to Next Group" (p)
1326 "Goes on to the next group in \"Netnews Groups\", setting the bboard pointer
1327 the the latest message read. With an argument does not modify the bboard
1328 pointer."
1329 "Goes on to the next group in \"Netnews Groups\", setting the bboard pointer
1330 the the latest message read. With an argument does not modify the bboard
1331 pointer."
1332 (nn-punt-headers (if p :none :latest)))
1333
1334 (defcommand "Netnews Punt Headers" (p)
1335 "Go on to the next group in \"Netnews Groups\" setting the netnews pointer
1336 for this bboard to the last visible message. With an argument, set the
1337 pointer to the last message in this group."
1338 "Go on to the next group in \"Netnews Groups\" setting the netnews pointer
1339 for this bboard to the last visible message. With an argument, set the
1340 pointer to the last message in this group."
1341 (nn-punt-headers (if p :punt :last-visible)))
1342
1343 (defcommand "Netnews Quit Starting Here" (p)
1344 "Go on to the next group in \"Netnews Groups\", setting the bboard pointer
1345 to the message before the currently displayed one or the message under
1346 the point if none is currently displayed."
1347 "Go on to the next group in \"Netnews Groups\", setting the bboard pointer
1348 to the message before the currently displayed one or the message under
1349 the point if none is currently displayed."
1350 (declare (ignore p))
1351 (nn-punt-headers :just-before))
1352
1353 (defun nn-punt-headers (pointer-type)
1354 (let* ((headers-buffer (nn-get-headers-buffer))
1355 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1356 (stream (nn-info-header-stream nn-info)))
1357 (message "Exiting ~A" (nn-info-current nn-info))
1358 (setf (nn-info-latest nn-info)
1359 (ecase pointer-type
1360 (:latest (nn-info-latest nn-info))
1361 (:punt (nn-info-last nn-info))
1362 (:last-visible (nn-info-last-visible nn-info))
1363 (:just-before
1364 (1- (if (minusp (nn-info-current-displayed-message nn-info))
1365 (array-element-from-mark (buffer-point headers-buffer)
1366 (nn-info-message-ids nn-info))
1367 (nn-info-current-displayed-message nn-info))))
1368 (:none nil)))
1369 ;; This clears out all headers that waiting on header-stream.
1370 ;; Must process each response in case a message is not really there.
1371 ;; If it isn't, then the call to WITH-INPUT-FROM-NNTP will gobble up
1372 ;; the error message and the next real article.
1373 ;;
1374 (when (nn-info-messages-waiting nn-info)
1375 (dotimes (i (nn-info-batch-count nn-info))
1376 (let ((response (process-status-response stream)))
1377 (when response (with-input-from-nntp (string stream))))))
1378 (change-to-next-group nn-info headers-buffer)))
1379
1380 (defcommand "Fetch All Headers" (p)
1381 "Fetches the rest of the headers in the current group.
1382 Warning: This will take a while if there are a lot."
1383 "Fetches the rest of the headers in the current group.
1384 Warning: This will take a while if there are a lot."
1385 (declare (ignore p))
1386 (let* ((headers-buffer (nn-get-headers-buffer))
1387 (nn-info (variable-value 'netnews-info :buffer headers-buffer)))
1388 (if (nn-info-messages-waiting nn-info)
1389 (message "Fetching the rest of the headers for ~A"
1390 (nn-info-current nn-info))
1391 (editor-error "All headers are in buffer."))
1392 ;; The first of these calls writes the headers that are waiting on the
1393 ;; headers stream and requests the rest. The second inserts the rest, if
1394 ;; there are any.
1395 ;;
1396 (nn-write-headers-to-mark nn-info headers-buffer t)
1397 (nn-write-headers-to-mark nn-info headers-buffer)))
1398
1399
1400 (defcommand "List All Newsgroups" (p &optional buffer)
1401 "Shows all available newsgroups in a buffer."
1402 "Shows all available newsgroups in a buffer."
1403 (declare (ignore p))
1404 (let* ((headers-buffer (nn-get-headers-buffer))
1405 (nn-info (if headers-buffer
1406 (variable-value 'netnews-info :buffer headers-buffer)))
1407 (stream (if headers-buffer
1408 (nn-info-stream nn-info)
1409 (connect-to-nntp))))
1410 (nntp-list stream)
1411 (message "Fetching group list...")
1412 (process-status-response stream)
1413 (let* ((buffer (or buffer (make-buffer (nn-new-list-newsgroups-name))))
1414 (point (buffer-point buffer))
1415 (groups (make-array 1500 :fill-pointer 0 :adjustable t)))
1416 (with-input-from-nntp (string (if headers-buffer
1417 (nn-info-stream nn-info)
1418 stream))
1419 (vector-push-extend string groups))
1420 (sort groups #'string<)
1421 (dotimes (i (length groups))
1422 (let ((group (aref groups i)))
1423 (multiple-value-bind (last first) (list-response-args group)
1424 (insert-string point group 0 (position #\space group))
1425 (insert-string point ": ")
1426 (insert-string point (format nil "~D" (1+ (- last first))))
1427 (insert-character point #\newline))))
1428 (setf (buffer-modified buffer) nil)
1429 (buffer-start point)
1430 (change-to-buffer buffer))
1431 (unless headers-buffer (close stream))))
1432
1433 (defun nn-new-list-newsgroups-name ()
1434 (let ((name "Newsgroups List")
1435 (number 0))
1436 (declare (simple-string name)
1437 (fixnum number))
1438 (loop
1439 (unless (getstring name *buffer-names*) (return name))
1440 (setf name (format nil "Newsgroups List ~D" number))
1441 (incf number))))
1442
1443 (defhvar "Netnews Message File"
1444 "This value is merged with your home directory to get the pathname of the
1445 file to which Hemlock will append messages."
1446 :value "hemlock.messages")
1447
1448 (defhvar "Netnews Prompt Before Exiting"
1449 "When non-nil, the default, \"Netnews Exit\" will ask you if you really
1450 want to. If this variable is NIL, you will not be prompted."
1451 :value T)
1452
1453 (defcommand "Netnews Exit" (p &optional no-prompt-p
1454 (headers-buf (nn-get-headers-buffer)))
1455 "Exit Netnews from a netnews headers or netnews message buffer."
1456 "Exit Netnews from a netnews headers or netnews message buffer."
1457 (declare (ignore p))
1458 (let ((browse-buffer (variable-value 'netnews-browse-buffer
1459 :buffer headers-buf)))
1460 (when (or browse-buffer
1461 no-prompt-p
1462 (not (value netnews-prompt-before-exiting))
1463 (prompt-for-y-or-n :prompt "Exit Netnews? "
1464 :default "Y"
1465 :default-string "Y"
1466 :help "Yes exits netnews mode."))
1467 (let* ((nn-info (variable-value 'netnews-info :buffer headers-buf))
1468 (message-buffer (nn-info-buffer nn-info))
1469 (headers-window (nn-info-headers-window nn-info))
1470 (message-window (nn-info-message-window nn-info)))
1471 (when (nn-info-updatep nn-info)
1472 (nn-update-database-file (nn-info-latest nn-info)
1473 (nn-info-current nn-info)))
1474 (when (and (eq (value netnews-read-style) :multiple)
1475 (member headers-window *window-list*)
1476 (member message-window *window-list*))
1477 (delete-window message-window))
1478 (when message-buffer (delete-buffer-if-possible message-buffer))
1479 (delete-buffer-if-possible headers-buf)
1480 (when browse-buffer (change-to-buffer browse-buffer))))))
1481
1482
1483
1484 ;;;; Commands to append messages to a file or file messages into mail folders.
1485
1486 (defcommand "Netnews Append to File" (p)
1487 "In a \"News-Headers\" buffer, appends the message under the point onto
1488 the file named by \"Netnews Message File\". In a \"News-Message\" buffer,
1489 appends the message in the current buffer to the same file."
1490 "In a \"News-Headers\" buffer, appends the message under the point onto
1491 the file named by \"Netnews Message File\". In a \"News-Message\" buffer,
1492 appends the message in the current buffer to the same file."
1493 (let* ((filename (merge-pathnames (value netnews-message-file)
1494 (user-homedir-pathname)))
1495 (file (prompt-for-file :prompt "Append to what file: "
1496 :must-exist nil
1497 :default filename
1498 :default-string (namestring filename))))
1499 (when (and p (probe-file file))
1500 (delete-file file))
1501 (message "Appending message to ~S" (namestring file))
1502 (cond ((hemlock-bound-p 'netnews-info)
1503 (let* ((nn-info (value netnews-info))
1504 (stream (nn-info-stream nn-info))
1505 (article-number (array-element-from-mark
1506 (current-point)
1507 (nn-info-message-ids nn-info)
1508 "No header under point.")))
1509 (with-open-file (file file :direction :output
1510 :element-type 'string-char
1511 :if-exists :append
1512 :if-does-not-exist :create)
1513 (nntp-article article-number stream)
1514 (process-status-response stream)
1515 (with-input-from-nntp (string (nn-info-stream nn-info))
1516 (write-line string file :end (1- (length string)))))))
1517 (t
1518 (write-file (buffer-region (current-buffer)) file)))
1519 ;; Put a page separator and some whitespace between messages for
1520 ;; readability when printing or scanning.
1521 ;;
1522 (with-open-file (f file :direction :output :if-exists :append)
1523 (terpri f)
1524 (terpri f)
1525 (write-line " " f)
1526 (terpri f))))
1527
1528 (defcommand "Netnews Headers File Message" (p)
1529 "Files the message under the point into a folder of your choice. If the
1530 folder you select does not exist, it is created."
1531 "Files the message under the point into a folder of your choice. If the
1532 folder you select does not exist, it is created."
1533 (declare (ignore p))
1534 (nn-file-message (value netnews-info) :headers))
1535
1536 (defcommand "Netnews Message File Message" (p)
1537 "Files the message in the current buffer into a folder of your choice. If
1538 folder you select does not exist, it is created."
1539 "Files the message in the current buffer into a folder of your choice. If
1540 folder you select does not exist, it is created."
1541 (declare (ignore p))
1542 (nn-file-message (variable-value 'netnews-info
1543 :buffer (nn-get-headers-buffer))
1544 :message))
1545
1546 (defun nn-file-message (nn-info kind)
1547 (let ((article-number (array-element-from-mark (current-point)
1548 (nn-info-message-ids nn-info)
1549 "No header under point."))
1550 (folder (prompt-for-folder :prompt "MH Folder: "
1551 :must-exist nil)))
1552 (unless (folder-existsp folder)
1553 (if (prompt-for-y-or-n
1554 :prompt "Destination folder doesn't exist. Create it? "
1555 :default t :default-string "Y")
1556 (create-folder folder)
1557 (editor-error "Not filing message.")))
1558 (message "Filing message into ~A" folder)
1559 (ecase kind
1560 (:headers (nntp-article article-number (nn-info-stream nn-info))
1561 (process-status-response (nn-info-stream nn-info))
1562 (with-open-file (s "/tmp/temp.msg" :direction :output
1563 :if-exists :rename-and-delete
1564 :if-does-not-exist :create)
1565 (with-input-from-nntp (string (nn-info-stream nn-info))
1566 (write-line string s :end (1- (length string))))))
1567 (:message (write-file (buffer-region (current-buffer)) "/tmp/temp.msg"
1568 :keep-backup nil)))
1569 (mh "inc" `(,folder "-silent" "-file" "/tmp/temp.msg"))
1570 (message "Done.")))
1571
1572
1573
1574 ;;;; "Post" Mode and supporting commands.
1575
1576 (defmode "Post" :major-p nil)
1577
1578 (defun nn-unique-post-buffer-name ()
1579 (let ((name "Post")
1580 (number 0))
1581 (loop
1582 (unless (getstring name *buffer-names*) (return name))
1583 (setf name (format nil "Post ~D" number))
1584 (incf number))))
1585
1586 ;;; We usually know what the subject and newsgroups are, so keep these patterns
1587 ;;; around to make finding where to insert the information easy.
1588 ;;;
1589 (defvar *draft-subject-pattern*
1590 (new-search-pattern :string-insensitive :forward "Subject:"))
1591
1592 (defvar *draft-newsgroups-pattern*
1593 (new-search-pattern :string-insensitive :forward "Newsgroups:"))
1594
1595 (defcommand "Netnews Post Message" (p)
1596 "Set up a buffer for posting to netnews."
1597 "Set up a buffer for posting to netnews."
1598 (declare (ignore p))
1599 (let ((headers-buf (nn-get-headers-buffer))
1600 (post-buf (nn-make-post-buffer)))
1601 ;; If we're in a "News-Headers" or "News-Message" buffer, fill in the
1602 ;; newsgroups: slot in the header.
1603 (when headers-buf
1604 (insert-string-after-pattern (buffer-point post-buf)
1605 *draft-newsgroups-pattern*
1606 (nn-info-current
1607 (variable-value
1608 'netnews-info :buffer headers-buf))))
1609 (nn-post-message nil post-buf)))
1610
1611 (defcommand "Netnews Abort Post" (p)
1612 "Abort the current post."
1613 "Abort the current post."
1614 (declare (ignore p))
1615 (delete-buffer-if-possible (current-buffer)))
1616
1617 (defun foobie-frob (post-info buffer)
1618 (declare (ignore post-info))
1619 (change-to-buffer buffer))
1620 #|
1621 #'(lambda (post-info buffer)
1622 (declare (ignore post-info))
1623 (print :changing) (force-output)
1624 (change-to-buffer buffer)
1625 (print :changed) (force-output))
1626 |#
1627 (defvar *netnews-post-frob-windows-hook* #'foobie-frob
1628 "This hook is FUNCALled in NN-POST-MESSAGE with a post-info structure and
1629 the corresponding \"POST\" buffer before a post is done.")
1630
1631 ;;; NN-POST-MESSAGE sets up a buffer for posting. If message buffer is
1632 ;;; supplied, it is associated with the post-info structure for the post
1633 ;;; buffer.
1634 ;;;
1635 (defun nn-post-message (message-buffer &optional (buffer (nn-make-post-buffer)))
1636 (setf (buffer-modified buffer) nil)
1637 (when message-buffer
1638 (setf (nm-info-post-buffer (variable-value 'netnews-message-info
1639 :buffer message-buffer))
1640 buffer))
1641 (let ((post-info (make-post-info :stream (connect-to-nntp)
1642 :headers-buffer (nn-get-headers-buffer)
1643 :message-buffer message-buffer)))
1644 (defhvar "Post Info"
1645 "Information needed to manipulate post buffers."
1646 :buffer buffer
1647 :value post-info)
1648 (funcall *netnews-post-frob-windows-hook* post-info buffer)))
1649
1650 (defun nn-make-post-buffer ()
1651 (let* ((buffer (make-buffer (nn-unique-post-buffer-name)
1652 :delete-hook (list #'nn-post-buffer-delete-hook)))
1653 (stream (make-hemlock-output-stream (buffer-point buffer))))
1654 (setf (buffer-minor-mode buffer "Post") t)
1655 (write-line "Newsgroups: " stream)
1656 (write-line "Subject: " stream)
1657 (write-string "Date: " stream)
1658 (format stream "~A~%" (string-capitalize
1659 (format-universal-time nil (get-universal-time)
1660 :style :government
1661 :print-weekday nil)))
1662 (write-char #\newline stream)
1663 (write-char #\newline stream)
1664 buffer))
1665
1666 ;;; The usual again. NULLify the appropriate stream slots in associated
1667 ;;; structures. Also call NN-REPLY-CLEANUP-SPLIT-WINDOWS to see if we
1668 ;;; need to delete one of the current windows.
1669 ;;;
1670 (defun nn-post-buffer-delete-hook (buffer)
1671 (nn-reply-cleanup-split-windows buffer)
1672 (let* ((post-info (variable-value 'post-info :buffer buffer))
1673 (message-buffer (post-info-message-buffer post-info)))
1674 (close (post-info-stream post-info))
1675 (when message-buffer
1676 (setf (nm-info-post-buffer (variable-value 'netnews-message-info
1677 :buffer message-buffer))
1678 nil))))
1679
1680 ;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a
1681 ;;; normal reply. *netnews-post-frob-windows-hook* is bound to this when
1682 ;;; "Netnews Reply To Message" is invoked."
1683 ;;;
1684 (defun nn-reply-using-current-window (post-info buffer)
1685 (declare (ignore post-info))
1686 ;; Make sure there is only one window in :multiple mode.
1687 ;;
1688 (let* ((nn-info (variable-value 'netnews-info
1689 :buffer (nn-get-headers-buffer)))
1690 (headers-window (nn-info-headers-window nn-info))
1691 (message-window (nn-info-message-window nn-info)))
1692 (when (and (eq (value netnews-read-style) :multiple)
1693 (member message-window *window-list*)
1694 (member headers-window *window-list*))
1695 (setf (current-window) message-window)
1696 (delete-window headers-window))
1697 (change-to-buffer buffer)))
1698
1699 ;;; NN-REPLY-IN-OTHER-WINDOW-HOOK does what NN-REPLY-USING-CURRENT-WINDOW
1700 ;;; does, but in addition splits the current window in half, displaying the
1701 ;;; message buffer on top, and the reply buffer on the bottom. Also set some
1702 ;;; slots in the post info structure so the cleanup function knowd to delete
1703 ;;; one of the two windows we've created.
1704 ;;;
1705 (defun nn-reply-in-other-window-hook (post-info buffer)
1706 (nn-reply-using-current-window post-info buffer)
1707 (let* ((message-window (current-window))
1708 (reply-window (make-window (buffer-start-mark buffer))))
1709 (setf (window-buffer message-window) (post-info-message-buffer post-info)
1710 (current-window) reply-window
1711 (post-info-message-window post-info) message-window
1712 (post-info-reply-window post-info) reply-window)))
1713
1714 ;;; NN-REPLY-CLEANUP-SPLIT-WINDOWS just deletes one of the windows that
1715 ;;; "Netnews Reply to Message in Other Window" created, if they still exist.
1716 ;;;
1717 (defun nn-reply-cleanup-split-windows (post-buffer)
1718 (let* ((post-info (variable-value 'post-info :buffer post-buffer))
1719 (reply-window (post-info-reply-window post-info)))
1720 (when (and (member (post-info-message-window post-info) *window-list*)
1721 (member reply-window *window-list*))
1722 (delete-window reply-window))))
1723
1724 (defcommand "Netnews Reply to Message" (p)
1725 "Set up a POST buffer and insert the proper newgroups: and subject: fields.
1726 Should be invoked from a \"News-Message\" or \"News-Headers\" buffer.
1727 In a message buffer, reply to the message in that buffer, in a headers
1728 buffer, reply to the message under the point."
1729 "Set up a POST buffer and insert the proper newgroups: and subject: fields.
1730 Should be invoked from a \"News-Message\" or \"News-Headers\" buffer.
1731 In a message buffer, reply to the message in that buffer, in a headers
1732 buffer, reply to the message under the point."
1733 (declare (ignore p))
1734 (let ((*netnews-post-frob-windows-hook* #'nn-reply-using-current-window))
1735 (nn-reply-to-message)))
1736
1737 (defcommand "Netnews Reply to Message in Other Window" (p)
1738 "Does exactly what \"Netnews Reply to Message\" does, but makes two windows.
1739 One of the windows displays the message being replied to, and the other
1740 displays the reply."
1741 "Does exactly what \"Netnews Reply to Message\" does, but makes two windows.
1742 One of the windows displays the message being replied to, and the other
1743 displays the reply."
1744 (declare (ignore p))
1745 (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook))
1746 (nn-reply-to-message)))
1747
1748 (defcommand "Netnews Forward Message" (p)
1749 "Creates a Draft buffer and places a copy of the current message in
1750 it, delimited by forwarded message markers."
1751 "Creates a Draft buffer and places a copy of the current message in
1752 it, delimited by forwarded message markers."
1753 (declare (ignore p))
1754 (let* ((headers-buffer (nn-get-headers-buffer))
1755 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1756 (message-buffer (nn-info-buffer nn-info))
1757 (nm-info (variable-value 'netnews-message-info :buffer message-buffer))
1758 (draft-buffer (sub-setup-message-draft "comp" :to-field))
1759 (dinfo (variable-value 'draft-information :buffer draft-buffer)))
1760 (setf (buffer-delete-hook draft-buffer)
1761 (list #'cleanup-netnews-draft-buffer))
1762 (when (nm-info-draft-buffer nm-info)
1763 (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info)))
1764 (setf (nm-info-draft-buffer nm-info) draft-buffer)
1765 (when headers-buffer
1766 (defhvar "Headers Buffer"
1767 "This is bound in message and draft buffers to their associated
1768 headers-buffer"
1769 :value headers-buffer :buffer draft-buffer))
1770 (setf (draft-info-headers-mark dinfo)
1771 (copy-mark (buffer-point headers-buffer)))
1772 (defhvar "Message Buffer"
1773 "This is bound in draft buffers to their associated message buffer."
1774 :value message-buffer :buffer draft-buffer)
1775 (with-mark ((mark (buffer-point draft-buffer) :left-inserting))
1776 (buffer-end mark)
1777 (insert-string mark (format nil "~%------- Forwarded Message~%~%"))
1778 (insert-string mark (format nil "~%------- End of Forwarded Message~%"))
1779 (line-offset mark -2 0)
1780 (insert-region mark (buffer-region message-buffer)))
1781 (nn-reply-using-current-window nil draft-buffer)))
1782
1783
1784 (defcommand "Netnews Reply via Mail" (p)
1785 "Reply to the sender of a message via mail using the Hemlock mailer."
1786 "Reply to the sender of a message via mail using the Hemlock mailer."
1787 (declare (ignore p))
1788 (let* ((headers-buffer (nn-get-headers-buffer))
1789 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1790 (article (if (and (hemlock-bound-p 'netnews-info)
1791 (minusp (nn-info-current-displayed-message nn-info)))
1792 (nn-put-article-in-buffer nn-info headers-buffer)
1793 (nn-info-current-displayed-message nn-info)))
1794 (message-buffer (nn-info-buffer nn-info))
1795 (nm-info (variable-value 'netnews-message-info :buffer message-buffer))
1796 (draft-buffer (sub-setup-message-draft "comp" :to-field))
1797 (dinfo (variable-value 'draft-information :buffer draft-buffer)))
1798 (setf (buffer-delete-hook draft-buffer)
1799 (list #'cleanup-netnews-draft-buffer))
1800 (when (nm-info-draft-buffer nm-info)
1801 (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info)))
1802 (setf (nm-info-draft-buffer nm-info) draft-buffer)
1803 (when headers-buffer
1804 (defhvar "Headers Buffer"
1805 "This is bound in message and draft buffers to their associated
1806 headers-buffer"
1807 :value headers-buffer :buffer draft-buffer))
1808 (setf (draft-info-headers-mark dinfo)
1809 (copy-mark (buffer-point headers-buffer)))
1810 (defhvar "Message Buffer"
1811 "This is bound in draft buffers to their associated message buffer."
1812 :value message-buffer :buffer draft-buffer)
1813 (let ((point (buffer-point draft-buffer))
1814 (to-field (or (nn-get-one-field nn-info "Reply-To" article)
1815 (nn-get-one-field nn-info "From" article))))
1816 (insert-string-after-pattern point
1817 *draft-to-pattern*
1818 to-field
1819 :end (1- (length to-field)))
1820 (let ((subject-field (nn-subject-replyify
1821 (nn-get-one-field nn-info "Subject" article))))
1822 (insert-string-after-pattern point
1823 *draft-subject-pattern*
1824 subject-field
1825 :end (1- (length subject-field)))))
1826 (nn-reply-using-current-window nil draft-buffer)))
1827
1828 ;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook
1829 ;;; because the generic one tries to set some slots in the related message-info
1830 ;;; structure which doesn't exist. This function just sets the draft buffer
1831 ;;; slot of netnews-message-info to nil so it won't screw you when you try
1832 ;;; to change to the associated draft buffer.
1833 ;;;
1834 (defun cleanup-netnews-draft-buffer (buffer)
1835 (when (hemlock-bound-p 'message-buffer :buffer buffer)
1836 (setf (nm-info-draft-buffer
1837 (variable-value 'netnews-message-info
1838 :buffer (variable-value 'message-buffer
1839 :buffer buffer)))
1840 nil))))
1841
1842 ;;; NN-REPLYIFY-SUBJECT simply adds "Re: " to the front of a string if it is
1843 ;;; not already there.
1844 ;;;
1845 (defun nn-subject-replyify (subject)
1846 (if (>= (length subject) 3)
1847 (if (not (string= subject "Re:" :end1 3 :end2 3))
1848 (concatenate 'simple-string "Re: " subject)
1849 subject)
1850 (concatenate 'simple-string "Re: " subject)))
1851
1852 (defun insert-string-after-pattern (mark search-pattern string
1853 &key (start 0) (end (length string)))
1854 (buffer-start mark)
1855 (when (and (plusp end)
1856 (find-pattern mark search-pattern))
1857 (insert-string (line-end mark) string start end))
1858 (buffer-end mark))
1859
1860 (defun nn-reply-to-message ()
1861 (let* ((headers-buffer (nn-get-headers-buffer))
1862 (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1863 (article (if (and (hemlock-bound-p 'netnews-info)
1864 (minusp (nn-info-current-displayed-message nn-info)))
1865 (nn-put-article-in-buffer nn-info headers-buffer)
1866 (nn-info-current-displayed-message nn-info)))
1867 (post-buffer (nn-make-post-buffer))
1868 (point (buffer-point post-buffer)))
1869
1870 (let ((groups-field (nn-get-one-field nn-info "Newsgroups" article)))
1871 (insert-string-after-pattern point
1872 *draft-newsgroups-pattern*
1873 groups-field
1874 :end (1- (length groups-field))))
1875 (let ((subject-field (nn-subject-replyify
1876 (nn-get-one-field nn-info "Subject" article))))
1877 (insert-string-after-pattern point
1878 *draft-subject-pattern*
1879 subject-field
1880 :end (1- (length subject-field))))
1881 (nn-post-message (nn-info-buffer nn-info) post-buffer)))
1882
1883 (defun nn-get-one-field (nn-info field article)
1884 (cdr (assoc field (aref (nn-info-header-cache nn-info)
1885 (- article (nn-info-first nn-info)))
1886 :test #'string-equal)))
1887
1888 (defvar *nntp-timeout-handler* 'nn-recover-from-timeout
1889 "This function gets FUNCALled when NNTP times out on us with the note passed
1890 to PROCESS-STATUS-RESPONSE. The default assumes the note is an NN-INFO
1891 structure and tries to recover from the timeout.")
1892
1893 (defvar *nn-last-command-issued* nil
1894 "The last string issued to one of the NNTP streams. Used to recover from
1895 a nntp timeout.")
1896
1897 ;;; NN-RECOVER-FROM-POSTING-TIMEOUT is the recover method used when posting.
1898 ;;; It just resets the value of \"NNTP Stream\" and issues the last command
1899 ;;; again.
1900 ;;;
1901 (defun nn-recover-from-posting-timeout (ignore)
1902 (declare (ignore ignore))
1903 (let ((stream (connect-to-nntp)))
1904 (setf (post-info-stream (value post-info)) stream)
1905 (write-nntp-command *nn-last-command-issued* stream :recover)
1906 (process-status-response stream)))
1907
1908 (defhvar "Netnews Reply Address"
1909 "What the From: field will be when you post messages. If this is nil,
1910 the From: field will be determined using the association of :USER
1911 in *environment-list* and your machine name."
1912 :value NIL)
1913
1914 (defhvar "Netnews Signature Filename"
1915 "This value is merged with your home directory to get the pathname your
1916 signature, which is appended to every post you make."
1917 :value ".hemlock-sig")
1918
1919 (defhvar "Netnews Deliver Post Confirm"
1920 "This determines whether Netnews Deliver Post will ask for confirmation
1921 before posting the current message."
1922 :value t)
1923
1924 (defcommand "Netnews Deliver Post" (p)
1925 "Deliver the current Post buffer to the NNTP server. If the file named by
1926 the value of \"Netnews Signature Filename\" exists, it is appended to the
1927 end of the message after adding a newline."
1928 "Deliver the current Post buffer to the NNTP server, cleaning up any windows
1929 we need and landing us in the headers buffer if this was a reply."
1930 (declare (ignore p))
1931 (when (or (not (value netnews-deliver-post-confirm))
1932 (prompt-for-y-or-n :prompt "Post message? " :default t))
1933 (let* ((*nntp-timeout-handler* #'nn-recover-from-posting-timeout)
1934 (stream (post-info-stream (value post-info))))
1935 (nntp-post stream)
1936 (let ((winp (process-status-response stream))
1937 ;; Rebind stream here because the stream may have been pulled out
1938 ;; from under us by an NNTP timeout. The recover method for posting
1939 ;; resets the Hemlock Variable.
1940 (stream (post-info-stream (value post-info))))
1941 (unless winp (editor-error "Posting prohibited on this board."))
1942 (let ((buffer (current-buffer))
1943 (username (value netnews-reply-address)))
1944 (nn-write-line (format nil "From: ~A"
1945 (if username
1946 username
1947 (string-downcase
1948 (format nil "~A@~A"
1949 (cdr (assoc :user
1950 ext:*environment-list*))
1951 (machine-instance)))))
1952 stream)
1953 (filter-region #'(lambda (string)
1954 (when (string= string ".")
1955 (write-char #\. stream))
1956 (nn-write-line string stream))
1957 (buffer-region buffer))
1958 ;; Append signature
1959 ;;
1960 (let ((filename (merge-pathnames (value netnews-signature-filename)
1961 (user-homedir-pathname))))
1962 (when (probe-file filename)
1963 (with-open-file (istream filename :direction :input)
1964 (loop
1965 (let ((line (read-line istream nil nil)))
1966 (unless line (return))
1967 (nn-write-line line stream))))))
1968 (write-line nntp-eof stream)
1969 (delete-buffer-if-possible buffer)
1970 (let ((headers-buffer (nn-get-headers-buffer)))
1971 (when headers-buffer (change-to-buffer headers-buffer)))
1972 (message "Message Posted."))))))
1973
1974 (defun nn-write-line (line stream)
1975 (write-string line stream)
1976 (write-char #\return stream)
1977 (write-char #\newline stream)
1978 line)
1979
1980
1981
1982 ;;;; News-Browse mode.
1983
1984 (defmode "News-Browse" :major-p t)
1985
1986 (defhvar "Netnews Group File"
1987 "If the value of \"Netnews Groups\" is nil, \"Netnews\" merges this
1988 variable with your home directory and looks there for a list of newsgroups
1989 (one per line) to read. Groups may be added using \"Netnews Browse\ and
1990 related commands, or by editing this file."
1991 :value ".hemlock-groups")
1992
1993 (defcommand "Netnews Browse" (p)
1994 "Puts all netnews groups in a buffer and provides commands for reading them
1995 and adding them to the file specified by the merge of \"Netnews Group File\"
1996 and your home directory."
1997 "Puts all netnews groups in a buffer and provides commands for reading them
1998 and adding them to the file specified by the merge of \"Netnews Group File\"
1999 and your home directory."
2000 (declare (ignore p))
2001 (let ((buffer (make-buffer "Netnews Browse")))
2002 (cond (buffer
2003 (list-all-newsgroups-command nil buffer)
2004 (setf (buffer-major-mode buffer) "News-Browse")
2005 (setf (buffer-writable buffer) nil))
2006 (t (change-to-buffer (getstring "Netnews Browse" *buffer-names*))))))
2007
2008 (defcommand "Netnews Quit Browse" (p)
2009 "Exit News-Browse Mode."
2010 "Exit News-Browse Mode."
2011 (declare (ignore p))
2012 (delete-buffer-if-possible (current-buffer)))
2013
2014 (defcommand "Netnews Browse Read Group" (p &optional (mark (current-point)))
2015 "Read the group on the line under the current point paying no attention to
2016 the \"Hemlock Database File\" entry for this group. With an argument, use
2017 and modify the database file."
2018 "Read the group on the line under the current point paying no attention to
2019 the \"Hemlock Database File\" entry for this group. With an argument, use
2020 and modify the database file."
2021 (let ((group-info-string (line-string (mark-line mark))))
2022 (netnews-command nil (subseq group-info-string
2023 0 (position #\: group-info-string))
2024 nil (current-buffer) p)))
2025
2026 (defcommand "Netnews Browse Pointer Read Group" (p)
2027 "Read the group on the line where you just clicked paying no attention to the
2028 \"Hemlock Databse File\" entry for this group. With an argument, use and
2029 modify the databse file."
2030 "Read the group on the line where you just clicked paying no attention to the
2031 \"Hemlock Databse File\" entry for this group. With an argument, use and
2032 modify the databse file."
2033 (multiple-value-bind (x y window) (last-key-event-cursorpos)
2034 (unless window (editor-error "Couldn't figure out where last click was."))
2035 (unless y (editor-error "There is no group in the modeline."))
2036 (netnews-browse-read-group-command p (cursorpos-to-mark x y window))))
2037
2038 (defcommand "Netnews Browse Add Newsgroup to File" (p &optional
2039 (mark (current-point)))
2040 "Append the newsgroup on the line under the point to the file specified by
2041 \"Netnews Group File\". With an argument, delete all groups that were
2042 there to start with."
2043 "Append the newsgroup on the line under the point to the file specified by
2044 \"Netnews Group File\". With an argument, delete all groups that were
2045 there to start with."
2046 (declare (ignore p))
2047 (let* ((group-info-string (line-string (mark-line mark)))
2048 (group (subseq group-info-string 0 (position #\: group-info-string))))
2049 (with-open-file (s (merge-pathnames (value netnews-group-file)
2050 (user-homedir-pathname))
2051 :direction :output
2052 :if-exists :append
2053 :if-does-not-exist :create)
2054 (write-line group s))
2055 (message "Adding ~S to newsgroup file." group)))
2056
2057 (defcommand "Netnews Browse Pointer Add Newsgroup to File" (p)
2058 "Append the newsgroup you just clicked on to the file specified by
2059 \"Netnews Group File\"."
2060 "Append the newsgroup you just clicked on to the file specified by
2061 \"Netnews Group File\"."
2062 (declare (ignore p))
2063 (multiple-value-bind (x y window) (last-key-event-cursorpos)
2064 (unless window (editor-error "Couldn't figure out where last click was."))
2065 (unless y (editor-error "There is no group in the modeline."))
2066 (netnews-browse-add-newsgroup-to-file-command
2067 nil (cursorpos-to-mark x y window))))
2068
2069
2070
2071 ;;;; Low-level stream operations.
2072
2073 (defun streams-for-nntp ()
2074 (clear-echo-area)
2075 (format *echo-area-stream* "Connecting to NNTP...~%")
2076 (force-output *echo-area-stream*)
2077 (values (connect-to-nntp) (connect-to-nntp)))
2078
2079
2080 (defparameter *nntp-port* 119
2081 "The nntp port number for NNTP as specified in RFC977.")
2082
2083 (defparameter *nntp-server* "netnews.srv.cs.cmu.edu"
2084 "The hostname of the nntp server to use.")
2085
2086 (defun connect-to-nntp ()
2087 (let ((stream (system:make-fd-stream
2088 (ext:connect-to-inet-socket *nntp-server* *nntp-port*)
2089 :input t :output t :buffering :line :name "NNTP")))
2090 (process-status-response stream)
2091 stream))
2092
2093 (defvar *nn-last-command-type* nil
2094 "Used to recover from a nntp timeout.")
2095
2096 (defun write-nntp-command (command stream type)
2097 (setf *nn-last-command-type* type)
2098 (setf *nn-last-command-issued* command)
2099 (write-string command stream)
2100 (write-char #\return stream)
2101 (write-char #\newline stream)
2102 (force-output stream))
2103
2104
2105
2106 ;;;; PROCESS-STATUS-RESPONSE and NNTP error handling.
2107
2108 (defconstant nntp-error-codes '(#\4 #\5)
2109 "These codes signal that NNTP could not complete the request you asked for.")
2110
2111 (defvar *nntp-error-handlers* nil)
2112
2113 ;;; PROCESS-STATUS-RESPONSE makes sure a response waiting at the server is
2114 ;;; valid. If the response code starts with a 4 or 5, then look it up in
2115 ;;; *nntp-error-handlers*. If an error handler is defined, then FUNCALL it
2116 ;;; on note. Otherwise editor error. If the response is not an error code,
2117 ;;; then just return what NNTP returned to us for parsing later.
2118 ;;;
2119 (defun process-status-response (stream &optional note)
2120 (let ((string (read-line stream)))
2121 (if (member (schar string 0) nntp-error-codes :test #'char=)
2122 (let ((error-handler (cdr (assoc string *nntp-error-handlers*
2123 :test #'(lambda (string1 string2)
2124 (string= string1 string2
2125 :end1 3
2126 :end2 3))))))
2127 (unless error-handler
2128 (error "NNTP error -- ~A" (subseq string 4 (1- (length string)))))
2129 (funcall error-handler note))
2130 string)))
2131
2132 (defun nn-recover-from-timeout (nn-info)
2133 (message "NNTP timed out, attempting to reconnect and continue...")
2134 (let ((stream (nn-info-stream nn-info))
2135 (header-stream (nn-info-header-stream nn-info)))
2136 ;; If some messages are waiting on the header stream, insert them.
2137 ;;
2138 (when (listen header-stream)
2139 (nn-write-headers-to-mark nn-info (nn-get-headers-buffer)))
2140 (close stream)
2141 (close header-stream)
2142 (setf stream (connect-to-nntp)
2143 header-stream (connect-to-nntp)
2144 (nn-info-stream nn-info) stream
2145 (nn-info-header-stream nn-info) header-stream)
2146 (let ((last-command *nn-last-command-issued*)
2147 (last-command-type *nn-last-command-type*)
2148 (current (nn-info-current nn-info)))
2149 (nntp-group current stream header-stream)
2150 (process-status-response stream)
2151 (process-status-response header-stream)
2152 (if (consp last-command)
2153 (let ((stream-type (car last-command)))
2154 (apply #'nn-send-many-head-requests
2155 (cons (if (eq stream-type :header) header-stream stream)
2156 (cdr last-command))))
2157 (ecase last-command-type
2158 ((:list :article :body)
2159 (write-nntp-command last-command stream :recover)
2160 (process-status-response stream))
2161 ((:header-group :normal-group)
2162 (write-nntp-command last-command stream :recover)
2163 (write-nntp-command last-command header-stream :recover)))))))
2164
2165 ;;; DEF-NNTP-ERROR-HANDLER takes a code and a function and associates the two
2166 ;;; in *nntp-error-handlers*. If while PROCESSING a STATUS RESPONSE we come
2167 ;;; across one of these error codes, then FUNCALL the appropriate handler.
2168 ;;;
2169 (defun def-nntp-error-handler (code function)
2170 (pushnew (cons (format nil "~D" code) function) *nntp-error-handlers*))
2171
2172 ;;; 503 is an NNTP timeout. The code I wrote reconnects and recovers
2173 ;;; completely.
2174 ;;;
2175 (def-nntp-error-handler 503 #'(lambda (note)
2176 (funcall *nntp-timeout-handler* note)))
2177
2178 ;;; 400 means NNTP is cutting us of for some reason. There is really nothing
2179 ;;; we can do.
2180 ;;;
2181 (def-nntp-error-handler 400 #'(lambda (ignore)
2182 (declare (ignore ignore))
2183 (editor-error "NNTP discontinued service. ~
2184 You should probably quit netnews and try ~
2185 again later.")))
2186
2187 ;;; Some functions just need to know that something went wrong so they can
2188 ;;; do something about it, so let them know by returning nil.
2189 ;;;
2190 ;;; 411 - The group you tried to read is not a netnews group.
2191 ;;; 423 - You requested a message that wasn't really there.
2192 ;;; 440 - Posting is not allowed.
2193 ;;; 441 - Posting is allowed, but the attempt failed for some other reason.
2194 ;;;
2195 (flet ((nil-function (ignore)
2196 (declare (ignore ignore))
2197 nil))
2198 (def-nntp-error-handler 423 #'nil-function)
2199 (def-nntp-error-handler 411 #'nil-function)
2200 (def-nntp-error-handler 440 #'nil-function)
2201 (def-nntp-error-handler 441 #'nil-function))
2202
2203
2204
2205 ;;;; Implementation of NNTP response argument parsing.
2206
2207 ;;; DEF-NNTP-ARG-PARSER returns a form that parses a string for arguments
2208 ;;; corresponding to each element of types. For instance, if types is
2209 ;;; (:integer :string :integer :integer), this function returns a form that
2210 ;;; parses an integer, a string, and two more integers out of an nntp status
2211 ;;; response.
2212 ;;;
2213 (defmacro def-nntp-arg-parser (types)
2214 (let ((form (gensym))
2215 (start (gensym))
2216 (res nil))
2217 (do ((type types (cdr type)))
2218 ((endp type) form)
2219 (ecase (car type)
2220 (:integer
2221 (push `(parse-integer string :start ,start
2222 :end (setf ,start
2223 (position #\space string
2224 :start (1+ ,start)))
2225 :junk-allowed t)
2226 res))
2227 (:string
2228 (push `(subseq string (1+ ,start)
2229 (position #\space string
2230 :start (setf ,start (1+ ,start))))
2231 res))))
2232 `(let ((,start (position #\space string)))
2233 (values ,@(nreverse res)))))
2234
2235 (defun def-nntp-xhdr-arg-parser (string)
2236 (let ((position (position #\space string)))
2237 (values (subseq string (1+ position))
2238 (parse-integer string :start 0 :end position))))
2239
2240 (defun xhdr-response-args (string)
2241 (def-nntp-xhdr-arg-parser string))
2242
2243 ;;; GROUP-RESPONSE-ARGS, ARTICLER-RESPONSE-ARGS, HEAD-RESPONSE-ARGS,
2244 ;;; BODY-RESPONSE-ARGS, and STAT-RESPONSE-ARGS define NNTP argument parsers
2245 ;;; for the types of arguments each command will return.
2246 ;;;
2247 (defun group-response-args (string)
2248 "Group response args are an estimate of how many messages there are,
2249 the number of the first message, the number of the last message, and \"y\"
2250 or \"n\", indicating whether the user has rights to post on this board."
2251 (def-nntp-arg-parser (:integer :integer :integer)))
2252
2253 (defun list-response-args (string)
2254 (def-nntp-arg-parser (:integer :integer)))
2255
2256 (defun article-response-args (string)
2257 "Article response args are the message number and the message ID."
2258 (def-nntp-arg-parser (:integer :string)))
2259
2260 (defun head-response-args (string)
2261 "Head response args are the message number and the message ID."
2262 (def-nntp-arg-parser (:integer :string)))
2263
2264 (defun body-response-args (string)
2265 "Body response args are the message number and the message ID."
2266 (def-nntp-arg-parser (:integer :string)))
2267
2268 (defun stat-response-args (string)
2269 "Stat response args are the message number and the message ID."
2270 (def-nntp-arg-parser (:integer :string)))
2271
2272
2273
2274 ;;;; Functions that send standard NNTP commands.
2275
2276 ;;; NNTP-XHDR sends an XHDR command to the NNTP server. We think this is a
2277 ;;; local extension, but not using it is not pragmatic. It takes over three
2278 ;;; minutes to HEAD every message in a newsgroup.
2279 ;;;
2280 (defun nntp-xhdr (field start end stream)
2281 (write-nntp-command (format nil "xhdr ~A ~D-~D"
2282 field
2283 (if (numberp start) start (parse-integer start))
2284 (if (numberp end) end (parse-integer end)))
2285 stream
2286 :xhdr))
2287
2288 (defun nntp-group (group-name stream header-stream)
2289 (let ((command (concatenate 'simple-string "group " group-name)))
2290 (write-nntp-command command stream :normal-group)
2291 (write-nntp-command command header-stream :header-group)))
2292
2293 (defun nntp-list (stream)
2294 (write-nntp-command "list" stream :list))
2295
2296 (defun nntp-head (article stream)
2297 (write-nntp-command (format nil "head ~D" article) stream :head))
2298
2299 (defun nntp-article (number stream)
2300 (write-nntp-command (format nil "article ~D" number) stream :article))
2301
2302 (defun nntp-body (number stream)
2303 (write-nntp-command (format nil "body ~D" number) stream :body))
2304
2305 (defun nntp-post (stream)
2306 (write-nntp-command "post" stream :post))
2307

  ViewVC Help
Powered by ViewVC 1.1.5