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

Diff of /src/hemlock/netnews.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by chiles, Mon Aug 12 07:19:38 1991 UTC revision 1.6 by chiles, Mon Aug 12 11:03:38 1991 UTC
# Line 7  Line 7 
7  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;; **********************************************************************  ;;; **********************************************************************
9  ;;;  ;;;
10  ;;;    Written by Blaine Burks  ;;; Written by Blaine Burks
11  ;;;  ;;;
12  ;;;  This file implements the reading of bulletin boards from within Hemlock  ;;; This file implements the reading of bulletin boards from within Hemlock
13  ;;;  via a known NNTP server.  Something should probably be done so that  ;;; 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.  ;;; 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  ;;; Warning:    Throughout this file, it may appear I should have bound
17  ;;;              the nn-info-stream and nn-info-header-stream slots instead  ;;;             the nn-info-stream and nn-info-header-stream slots instead
18  ;;;              of making multiple structure accesses.  This was done on  ;;;             of making multiple structure accesses.  This was done on
19  ;;;              purpose because we don't find out if NNTP timed us out until  ;;;             purpose because we don't find out if NNTP timed us out until
20  ;;;              we make an attempt to execute another command.  This code  ;;;             we make an attempt to execute another command.  This code
21  ;;;              recovers by resetting the header-stream and stream slots in  ;;;             recovers by resetting the header-stream and stream slots in
22  ;;;              the nn-info structure to new streams.  If the structure  ;;;             the nn-info structure to new streams.  If the structure
23  ;;;              access were not made again and NNTP had timed us out, we  ;;;             access were not made again and NNTP had timed us out, we
24  ;;;              would be making requests on a defunct stream.  ;;;             would be making requests on a defunct stream.
25  ;;;  ;;;
26    
27  (in-package "HEMLOCK")  (in-package "HEMLOCK")
28    
29    
# Line 50  Line 51 
51    ;; The cache of header info for the current bboard.  Each element contains    ;; The cache of header info for the current bboard.  Each element contains
52    ;; an association list of header fields to contents of those fields.  Indexed    ;; an association list of header fields to contents of those fields.  Indexed
53    ;; by id offset by the first message in the group.    ;; by id offset by the first message in the group.
54    (header-cache nil :type (or null vector))    (header-cache nil :type (or null simple-vector))
55    ;;    ;;
56    ;; The number of HEAD requests currently waiting on the header stream.    ;; The number of HEAD requests currently waiting on the header stream.
57    (batch-count nil :type (or null fixnum))    (batch-count nil :type (or null fixnum))
# Line 442  Line 443 
443                         (cond ((> length (nn-info-array-length nn-info))                         (cond ((> length (nn-info-array-length nn-info))
444                                (setf (nn-info-array-length nn-info) length)                                (setf (nn-info-array-length nn-info) length)
445                                (values (make-array length :fill-pointer 0)                                (values (make-array length :fill-pointer 0)
446                                        (make-array length :fill-pointer 0                                        (make-array length
447                                                    :initial-element nil)))                                                    :initial-element nil)))
448                               (message-ids                               (message-ids
                               (unless (zerop (length header-cache))  
                                 (fill header-cache nil))  
449                                (setf (fill-pointer message-ids) 0)                                (setf (fill-pointer message-ids) 0)
                               (setf (fill-pointer header-cache) 0)  
450                                (values message-ids header-cache))                                (values message-ids header-cache))
451                               (t                               (t
452                                (values (make-array (nn-info-array-length nn-info)                                (values (make-array (nn-info-array-length nn-info)
453                                                    :fill-pointer 0)                                                    :fill-pointer 0)
454                                        (make-array (nn-info-array-length nn-info)                                        (make-array (nn-info-array-length nn-info)
                                                   :fill-pointer 0  
455                                                    :initial-element nil)))))                                                    :initial-element nil)))))
456                     (setf (nn-info-message-ids nn-info) message-ids)                     (setf (nn-info-message-ids nn-info) message-ids)
457                     (setf (nn-info-header-cache nn-info) header-cache))                     (setf (nn-info-header-cache nn-info) header-cache))
# Line 594  Line 591 
591                (let* ((id (head-response-args response))                (let* ((id (head-response-args response))
592                       (index (- id offset)))                       (index (- id offset)))
593                  (vector-push id message-ids)                  (vector-push id message-ids)
594                    (setf (svref cache index) nil)
595                  (with-input-from-nntp (string stream)                  (with-input-from-nntp (string stream)
596                                        (let ((colonpos (position #\: string)))                                        (let ((colonpos (position #\: string)))
597                                          (when colonpos                                          (when colonpos
598                                            (push (cons (subseq string 0 colonpos)                                            (push (cons (subseq string 0 colonpos)
599                                                        (subseq string                                                        (subseq string
600                                                                (+ colonpos 2)))                                                                (+ colonpos 2)))
601                                                  (aref cache index))))))                                                  (svref cache index))))))
602                (incf missing-message-count))))                (incf missing-message-count))))
603        (when from-end-p        (when from-end-p
604          (when (plusp missing-message-count)          (when (plusp missing-message-count)
# Line 610  Line 608 
608          (setf (fill-pointer message-ids)          (setf (fill-pointer message-ids)
609                (- (+ old-count howmany) missing-message-count))))))                (- (+ old-count howmany) missing-message-count))))))
610    
611  (defvar netnews-field-na "NA"  (defconstant netnews-field-na "NA"
612    "This string gets inserted when NNTP doesn't find a field.")    "This string gets inserted when NNTP doesn't find a field.")
613    
614  (defvar netnews-field-na-length (length netnews-field-na)  (defconstant netnews-field-na-length (length netnews-field-na)
615    "The length of netnews-field-na")    "The length of netnews-field-na")
616    
617  (defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p  (defun nn-write-headers-to-mark (nn-info buffer &optional fetch-rest-p
# Line 658  Line 656 
656                   (end (1- (+ start howmany))))                   (end (1- (+ start howmany))))
657              (do ((i start (1+ i)))              (do ((i start (1+ i)))
658                  ((> i end))                  ((> i end))
659                (let ((assoc-list (aref cache i)))                (let ((assoc-list (svref cache i)))
660                  (unless (null assoc-list)                  (unless (null assoc-list)
661                    (insert-string mark netnews-space-string                    (insert-string mark netnews-space-string
662                                   0 (value netnews-before-date-field-pad))                                   0 (value netnews-before-date-field-pad))
# Line 860  Line 858 
858  ;;; page of it.  Also check to make sure there is a message under the  ;;; page of it.  Also check to make sure there is a message under the
859  ;;; point.  If there is not, then get some more headers.  If there are no  ;;; point.  If there is not, then get some more headers.  If there are no
860  ;;; more headers, then go on to the next board.  I can read and write.  Hi  ;;; more headers, then go on to the next board.  I can read and write.  Hi
861  ;;; Bill.  Are you having fun grocking my code?  Hope so -- Dude.  Nothing  ;;; Bill.  Are you having fun grokking my code?  Hope so -- Dude.  Nothing
862  ;;; like stream of consciousness is there?  Come to think of it, this is  ;;; like stream of consciousness is there?  Come to think of it, this is
863  ;;; kind of like recursive stream of conscious because I'm writing down my  ;;; kind of like recursive stream of conscious because I'm writing down my
864  ;;; stream of conscious which is about my stream of conscious. I think I'm  ;;; stream of conscious which is about my stream of conscious. I think I'm
# Line 944  Line 942 
942    field should be limited."    field should be limited."
943    :value nil)    :value nil)
944    
945    
946    (defcommand "Netnews Show All Headers" (p)
947      "" ""
948      (declare (ignore p))
949      (let* ((headers-buffer (nn-get-headers-buffer))
950             (nn-info (variable-value 'netnews-info :buffer headers-buffer))
951             (buffer (nn-get-message-buffer nn-info)))
952        (with-writable-buffer (buffer)
953          (delete-region (buffer-region buffer))
954          (nn-put-article-in-buffer nn-info headers-buffer t))))
955    
956  ;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the  ;;; NN-PUT-ARTICLE-IN-BUFFER puts the article under the point into the
957  ;;; associated message buffer if it is not there already.  Uses value of  ;;; associated message buffer if it is not there already.  Uses value of
958  ;;; "Netnews Message Header Fields" to determine what fields should appear  ;;; "Netnews Message Header Fields" to determine what fields should appear
959  ;;; in the message header.  Returns the number of the article under the  ;;; in the message header.  Returns the number of the article under the
960  ;;; point.  ;;; point.
961  ;;;  ;;;
962  (defun nn-put-article-in-buffer (nn-info headers-buffer)  (defun nn-put-article-in-buffer (nn-info headers-buffer &optional override)
963    (let ((stream (nn-info-stream nn-info))    (let ((stream (nn-info-stream nn-info))
964          (article-number (array-element-from-mark          (article-number (array-element-from-mark
965                           (buffer-point headers-buffer)                           (buffer-point headers-buffer)
# Line 959  Line 968 
968      (setf (nm-info-message-number (variable-value 'netnews-message-info      (setf (nm-info-message-number (variable-value 'netnews-message-info
969                                                    :buffer message-buffer))                                                    :buffer message-buffer))
970            (1+ (- article-number (nn-info-first nn-info))))            (1+ (- article-number (nn-info-first nn-info))))
971      (cond ((= (nn-info-current-displayed-message nn-info) article-number)      (cond ((and (= (nn-info-current-displayed-message nn-info) article-number)
972                    (not override))
973             (buffer-start (buffer-point message-buffer)))             (buffer-start (buffer-point message-buffer)))
974            (t            (t
975             ;; Request article as soon as possible to avoid waiting for reply.             ;; Request article as soon as possible to avoid waiting for reply.
# Line 969  Line 979 
979             (process-status-response stream nn-info)             (process-status-response stream nn-info)
980             (with-writable-buffer (message-buffer)             (with-writable-buffer (message-buffer)
981               (let ((point (buffer-point message-buffer))               (let ((point (buffer-point message-buffer))
982                     (info (aref (nn-info-header-cache nn-info)                     (info (svref (nn-info-header-cache nn-info)
983                                  (- article-number (nn-info-first nn-info))))                                  (- article-number (nn-info-first nn-info))))
984                     (message-fields (value netnews-message-header-fields))                     (message-fields (value netnews-message-header-fields))
985                     key field-length)                     key field-length)
986                 (cond (message-fields                 (cond ((and message-fields
987                               (not override))
988                        (dolist (ele message-fields)                        (dolist (ele message-fields)
989                          (etypecase ele                          (etypecase ele
990                            (atom (setf key ele field-length nil))                            (atom (setf key ele field-length nil))
# Line 1685  Line 1696 
1696  ;;; need to delete one of the current windows.  ;;; need to delete one of the current windows.
1697  ;;;  ;;;
1698  (defun nn-post-buffer-delete-hook (buffer)  (defun nn-post-buffer-delete-hook (buffer)
1699    (nn-reply-cleanup-split-windows buffer)    (when (hemlock-bound-p 'post-info)
1700    (let* ((post-info (variable-value 'post-info :buffer buffer))      (nn-reply-cleanup-split-windows buffer)
1701           (message-buffer (post-info-message-buffer post-info)))      (let* ((post-info (variable-value 'post-info :buffer buffer))
1702      (close (post-info-stream post-info))             (message-buffer (post-info-message-buffer post-info)))
1703      (when message-buffer        (close (post-info-stream post-info))
1704        (setf (nm-info-post-buffer (variable-value 'netnews-message-info        (when message-buffer
1705                                                   :buffer message-buffer))          (setf (nm-info-post-buffer (variable-value 'netnews-message-info
1706              nil))))                                                     :buffer message-buffer))
1707                  nil)))))
1708    
1709  ;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a  ;;; NN-REPLY-USING-CURRENT-WINDOW makes sure there is only one window for a
1710  ;;; normal reply.  *netnews-post-frob-windows-hook* is bound to this when  ;;; normal reply.  *netnews-post-frob-windows-hook* is bound to this when
# Line 1898  Line 1910 
1910      (nn-post-message (nn-info-buffer nn-info) post-buffer)))      (nn-post-message (nn-info-buffer nn-info) post-buffer)))
1911    
1912  (defun nn-get-one-field (nn-info field article)  (defun nn-get-one-field (nn-info field article)
1913    (cdr (assoc field (aref (nn-info-header-cache nn-info)    (cdr (assoc field (svref (nn-info-header-cache nn-info)
1914                            (- article (nn-info-first nn-info)))                            (- article (nn-info-first nn-info)))
1915                :test #'string-equal)))                :test #'string-equal)))
1916    

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

  ViewVC Help
Powered by ViewVC 1.1.5