/[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.9 by chiles, Mon Sep 16 11:27:46 1991 UTC revision 1.10 by chiles, Thu Nov 14 20:33:36 1991 UTC
# Line 223  Line 223 
223    :value :from-end)    :value :from-end)
224    
225  (defhvar "Netnews Start Over Threshold"  (defhvar "Netnews Start Over Threshold"
226    "If you have read a group before, and the number of new messages exceeds this    "If you have read a group before, and the number of new messages exceeds
227     number, Hemlock asks whether you want to start reading from the end of this     this number, Hemlock asks whether you want to start reading from the end
228     group.  The default is 300."     of this group.  The default is 300."
229    :value 300)    :value 300)
230    
231  (defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t))  (defcommand "Netnews" (p &optional group-name from-end-p browse-buf (updatep t))
232    "Enter a headers buffer and read groups from \"Netnews Group File\".  With    "Enter a headers buffer and read groups from \"Netnews Group File\".
233     an argument prompts for a group and reads it."     With an argument prompts for a group and reads it."
234    "Enter a headers buffer and read groupss from \"Netnews Group File\".  With    "Enter a headers buffer and read groups from \"Netnews Group File\".
235     an argument prompts for a group and reads it."     With an argument prompts for a group and reads it."
236    (cond    (cond
237     ((and *nn-headers-buffer* (not p) (not group-name))     ((and *nn-headers-buffer* (not p) (not group-name))
238      (change-to-buffer *nn-headers-buffer*))      (change-to-buffer *nn-headers-buffer*))
# Line 1774  Line 1774 
1774  ;;;  ;;;
1775  (defun nn-reply-cleanup-split-windows (post-buffer)  (defun nn-reply-cleanup-split-windows (post-buffer)
1776    (let* ((post-info (variable-value 'post-info :buffer post-buffer))    (let* ((post-info (variable-value 'post-info :buffer post-buffer))
1777           (reply-window (post-info-reply-window post-info)))           (message-window (post-info-message-window post-info)))
1778      (when (and (member (post-info-message-window post-info) *window-list*)      (when (and (member (post-info-reply-window post-info) *window-list*)
1779                 (member reply-window *window-list*))                 (member message-window *window-list*))
1780        (delete-window reply-window))))        (delete-window message-window))))
1781    
1782  (defcommand "Netnews Reply to Group" (p)  (defcommand "Netnews Reply to Group" (p)
1783    "Set up a POST buffer and insert the proper newgroups: and subject: fields.    "Set up a POST buffer and insert the proper newgroups: and subject: fields.
# Line 1803  Line 1803 
1803    (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook))    (let ((*netnews-post-frob-windows-hook* #'nn-reply-in-other-window-hook))
1804      (nn-reply-to-message)))      (nn-reply-to-message)))
1805    
1806  (defcommand "Netnews Forward Message" (p)  
1807    "Creates a Draft buffer and places a copy of the current message in  (defun nn-setup-for-reply-by-mail ()
    it, delimited by forwarded message markers."  
   "Creates a Draft buffer and places a copy of the current message in  
    it, delimited by forwarded message markers."  
   (declare (ignore p))  
1808    (let* ((headers-buffer (nn-get-headers-buffer))    (let* ((headers-buffer (nn-get-headers-buffer))
1809           (nn-info (variable-value 'netnews-info :buffer headers-buffer))           (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1810           (message-buffer (nn-info-buffer nn-info))           (message-buffer (nn-info-buffer nn-info))
# Line 1830  Line 1826 
1826      (defhvar "Message Buffer"      (defhvar "Message Buffer"
1827        "This is bound in draft buffers to their associated message buffer."        "This is bound in draft buffers to their associated message buffer."
1828        :value message-buffer :buffer draft-buffer)        :value message-buffer :buffer draft-buffer)
1829        (values draft-buffer message-buffer)))
1830    
1831    
1832    (defcommand "Netnews Forward Message" (p)
1833      "Creates a Draft buffer and places a copy of the current message in
1834       it, delimited by forwarded message markers."
1835      "Creates a Draft buffer and places a copy of the current message in
1836       it, delimited by forwarded message markers."
1837      (declare (ignore p))
1838      (multiple-value-bind (draft-buffer message-buffer)
1839                           (nn-setup-for-reply-by-mail)
1840      (with-mark ((mark (buffer-point draft-buffer) :left-inserting))      (with-mark ((mark (buffer-point draft-buffer) :left-inserting))
1841        (buffer-end mark)        (buffer-end mark)
1842        (insert-string mark (format nil "~%------- Forwarded Message~%~%"))        (insert-string mark (format nil "~%------- Forwarded Message~%~%"))
# Line 1839  Line 1846 
1846      (nn-reply-using-current-window nil draft-buffer)))      (nn-reply-using-current-window nil draft-buffer)))
1847    
1848    
1849  (defcommand "Netnews Reply to Sender" (p)  (defun nn-reply-to-sender ()
   "Reply to the sender of a message via mail using the Hemlock mailer."  
   "Reply to the sender of a message via mail using the Hemlock mailer."  
   (declare (ignore p))  
1850    (let* ((headers-buffer (nn-get-headers-buffer))    (let* ((headers-buffer (nn-get-headers-buffer))
1851           (nn-info (variable-value 'netnews-info :buffer headers-buffer))           (nn-info (variable-value 'netnews-info :buffer headers-buffer))
1852           (article (if (and (hemlock-bound-p 'netnews-info)           (article (if (and (hemlock-bound-p 'netnews-info)
1853                             (minusp (nn-info-current-displayed-message nn-info)))                             (minusp (nn-info-current-displayed-message
1854                                        nn-info)))
1855                        (nn-put-article-in-buffer nn-info headers-buffer)                        (nn-put-article-in-buffer nn-info headers-buffer)
1856                        (nn-info-current-displayed-message nn-info)))                        (nn-info-current-displayed-message nn-info))))
1857           (message-buffer (nn-info-buffer nn-info))      (multiple-value-bind (draft-buffer message-buffer)
1858           (nm-info (variable-value 'netnews-message-info :buffer message-buffer))                           (nn-setup-for-reply-by-mail)
1859           (draft-buffer (sub-setup-message-draft "comp" :to-field))        (let ((point (buffer-point draft-buffer))
1860           (dinfo (variable-value 'draft-information :buffer draft-buffer)))              (to-field (or (nn-get-one-field nn-info "Reply-To" article)
1861      (setf (buffer-delete-hook draft-buffer)                            (nn-get-one-field nn-info "From" article))))
           (list #'cleanup-netnews-draft-buffer))  
     (when (nm-info-draft-buffer nm-info)  
       (delete-variable 'message-buffer :buffer (nm-info-draft-buffer nm-info)))  
     (setf (nm-info-draft-buffer nm-info) draft-buffer)  
     (when headers-buffer  
       (defhvar "Headers Buffer"  
         "This is bound in message and draft buffers to their associated  
         headers-buffer"  
         :value headers-buffer :buffer draft-buffer))  
     (setf (draft-info-headers-mark dinfo)  
           (copy-mark (buffer-point headers-buffer)))  
     (defhvar "Message Buffer"  
       "This is bound in draft buffers to their associated message buffer."  
       :value message-buffer :buffer draft-buffer)  
     (let ((point (buffer-point draft-buffer))  
           (to-field (or (nn-get-one-field nn-info "Reply-To" article)  
                         (nn-get-one-field nn-info "From" article))))  
       (insert-string-after-pattern point  
                                    *draft-to-pattern*  
                                    to-field  
                                    :end (1- (length to-field)))  
       (let ((subject-field (nn-subject-replyify  
                             (nn-get-one-field nn-info "Subject" article))))  
1862          (insert-string-after-pattern point          (insert-string-after-pattern point
1863                                       *draft-subject-pattern*                                       *draft-to-pattern*
1864                                       subject-field                                       to-field
1865                                       :end (1- (length subject-field)))))                                       :end (1- (length to-field)))
1866      (nn-reply-using-current-window nil draft-buffer)))          (let ((subject-field (nn-subject-replyify
1867                                  (nn-get-one-field nn-info "Subject" article))))
1868              (insert-string-after-pattern point
1869                                           *draft-subject-pattern*
1870                                           subject-field
1871                                           :end (1- (length subject-field)))))
1872          (nn-reply-using-current-window nil draft-buffer)
1873          (values draft-buffer message-buffer))))
1874    
1875    (defcommand "Netnews Reply to Sender" (p)
1876      "Reply to the sender of a message via mail using the Hemlock mailer."
1877      "Reply to the sender of a message via mail using the Hemlock mailer."
1878      (declare (ignore p))
1879      (nn-reply-to-sender))
1880    
1881    (defcommand "Netnews Reply to Sender in Other Window" (p)
1882      "Reply to the sender of a message via mail using the Hemlock mailer.  The
1883       screen will be split in half, displaying the post and the draft being
1884       composed."
1885      "Reply to the sender of a message via mail using the Hemlock mailer.  The
1886       screen will be split in half, displaying the post and the draft being
1887       composed."
1888      (declare (ignore p))
1889      (multiple-value-bind (draft-buffer message-buffer)
1890                           (nn-reply-to-sender)
1891        (let* ((message-window (current-window))
1892               (reply-window (make-window (buffer-start-mark draft-buffer))))
1893          (defhvar "Split Window Draft"
1894            "Indicates window needs to be cleaned up for draft."
1895            :value t :buffer draft-buffer)
1896          (setf (window-buffer message-window) message-buffer
1897                (current-window) reply-window))))
1898    
1899  ;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook  ;;; CLEANUP-NETNEWS-DRAFT-BUFFER replaces the normal draft buffer delete hook
1900  ;;; because the generic one tries to set some slots in the related message-info  ;;; because the generic one tries to set some slots in the related message-info
# Line 2138  Line 2151 
2151  (defparameter *nntp-port* 119  (defparameter *nntp-port* 119
2152    "The nntp port number for NNTP as specified in RFC977.")    "The nntp port number for NNTP as specified in RFC977.")
2153    
2154  (defparameter *nntp-server* "netnews.srv.cs.cmu.edu"  (defhvar "Netnews NNTP Server"
2155    "The hostname of the nntp server to use.")    "The hostname of the NNTP server to use for reading Netnews."
2156      :value "netnews.srv.cs.cmu.edu")
2157    
2158    (defhvar "Netnews NNTP Timeout Period"
2159      "The number of seconds to wait before timing out when trying to connect
2160       to the NNTP server."
2161      :value 30)
2162    
2163  (defun connect-to-nntp ()  (defun raw-connect-to-nntp ()
2164    (let ((stream (system:make-fd-stream    (let ((stream (system:make-fd-stream
2165                   (ext:connect-to-inet-socket *nntp-server* *nntp-port*)                   (ext:connect-to-inet-socket (value netnews-nntp-server)
2166                   :input t :output t :buffering :line :name "NNTP")))                                               *nntp-port*)
2167                     :input t :output t :buffering :line :name "NNTP"
2168                     :timeout (value netnews-nntp-timeout-period))))
2169      (process-status-response stream)      (process-status-response stream)
2170      stream))      stream))
2171    
2172    (defun connect-to-nntp ()
2173      (handler-case
2174          (raw-connect-to-nntp)
2175        (io-timeout ()
2176          (editor-error "Connection to NNTP timed out.  Try again later."))))
2177    
2178  (defvar *nn-last-command-type* nil  (defvar *nn-last-command-type* nil
2179    "Used to recover from a nntp timeout.")    "Used to recover from a nntp timeout.")
2180    
# Line 2175  Line 2202 
2202  ;;; then just return what NNTP returned to us for parsing later.  ;;; then just return what NNTP returned to us for parsing later.
2203  ;;;  ;;;
2204  (defun process-status-response (stream &optional note)  (defun process-status-response (stream &optional note)
2205    (let ((string (read-line stream)))    (let ((str (read-line stream)))
2206      (if (member (schar string 0) nntp-error-codes :test #'char=)      (if (member (schar str 0) nntp-error-codes :test #'char=)
2207          (let ((error-handler (cdr (assoc string *nntp-error-handlers*          (let ((error-handler (cdr (assoc str *nntp-error-handlers*
2208                                           :test #'(lambda (string1 string2)                                           :test #'(lambda (string1 string2)
2209                                                     (string= string1 string2                                                     (string= string1 string2
2210                                                              :end1 3                                                              :end1 3
2211                                                              :end2 3))))))                                                              :end2 3))))))
2212            (unless error-handler            (unless error-handler
2213              (error "NNTP error -- ~A" (subseq string 4 (1- (length string)))))              (error "NNTP error -- ~A" (subseq str 4 (1- (length str)))))
2214            (funcall error-handler note))            (funcall error-handler note))
2215          string)))          str)))
2216    
2217  (defun nn-recover-from-timeout (nn-info)  (defun nn-recover-from-timeout (nn-info)
2218    (message "NNTP timed out, attempting to reconnect and continue...")    (message "NNTP timed out, attempting to reconnect and continue...")

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

  ViewVC Help
Powered by ViewVC 1.1.5