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

Contents of /src/hemlock/netnews.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5