home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / gnus-xover-1.2 / nntp.el < prev    next >
Encoding:
Text File  |  1993-04-16  |  14.3 KB  |  462 lines
  1. ;;;;;;;;;;;;;;;;
  2. ;;; An NNTP module for GNUS.
  3.  
  4. ;; $Id: nntp.el,v 1.10 1993/02/04 18:23:39 flee Exp $
  5. (defvar nntp/rcs-revision "$Revision: 1.10 $")
  6.  
  7. (provide 'nntp)
  8. (require 'backquote)
  9. (require 'chat)
  10. (or (fboundp 'open-network-stream) (require 'tcp))
  11.  
  12. (or (fboundp 'last)
  13.     (defun last (x)
  14.       "Returns the last link in the list LIST."
  15.       (while (cdr x)
  16.     (setq x (cdr x)))
  17.       x))
  18.  
  19. (defvar nntp/default-nntp-port "nntp"
  20.   "The default tcp port to use for nntp connections.")
  21.  
  22. ;;;;;;;;;;;;;;;;
  23. ;;; NNTP state.
  24.  
  25. ;; Right now, we're assuming we only talk to one NNTP server at a
  26. ;; time.  It might be nice to do multiple NNTP connections, but
  27. ;; there's no point in doing this from the bottom up.
  28.  
  29. ;; (To handle multiple connections, you need to create connection
  30. ;; handles that you pass around.  Ideally, nnspool et al would be
  31. ;; just different types of connection handles.)
  32.  
  33. (defvar nntp/connection nil
  34.   "The current NNTP connection.")
  35.  
  36. (defvar nntp/error-message nil
  37.   "The error message from the last NNTP command.  'nil if no error.")
  38.  
  39. (defvar nntp/can-xover t
  40.   "Does this server understand the XOVER command?")
  41.  
  42. ;;;;;;;;;;;;;;;;
  43. ;;; The GNUS interface.
  44.  
  45. ;; These are the symbols that GNUS knows about and expects.
  46.  
  47. ;; The interaction between GNUS and nntp.el (or nnspool.el) is a
  48. ;; little messy and not particularly well defined.
  49.  
  50. (defvar nntp-version
  51.   (concat "flee/nntp " (substring nntp/rcs-revision 10)))
  52.  
  53. (defvar nntp-server-buffer nil
  54.   "Buffer that GNUS looks at when it wants data.")
  55.  
  56. (defun nntp-open-server (host service)
  57.   "Start a connection to the given HOST and SERVICE.  Returns true
  58. if successful."
  59.   ;; XXX already open?
  60.   (or service (setq service nntp/default-nntp-port))
  61.   (setq nntp/error-message nil)
  62.   (setq nntp/can-xover t)
  63.   (setq nntp-server-buffer (generate-new-buffer "*nntp*"))
  64.   (buffer-flush-undo nntp-server-buffer)
  65.   (setq nntp/connection
  66.     (open-network-stream "nntp" nntp-server-buffer host service))
  67.   (set-process-sentinel nntp/connection 'nntp/sentinel)
  68.   (process-kill-without-query nntp/connection)
  69.   (let ( (code (nntp/response)) )
  70.     (or (eq code 200) (eq code 201))))
  71.  
  72. (defun nntp-server-opened ()
  73.   "Are we currently connected?"
  74.   (and nntp/connection
  75.        (memq (process-status nntp/connection) '(run open))))
  76. ;; XXX should we add stopped to this list?
  77.  
  78. (defun nntp-close-server ()
  79.   "Terminate the connection.  Returns nothing."
  80.   (let ( (proc nntp/connection)
  81.      (buffer nntp-server-buffer) )
  82.     (setq nntp/connection nil)
  83.     (setq nntp-server-buffer nil)
  84.     (and proc (delete-process proc))
  85.     (and buffer (kill-buffer buffer))))
  86.  
  87. (defun nntp-status-message ()
  88.   "Returns the error message from the last NNTP request."
  89.   (or nntp/error-message "okay"))
  90.  
  91. (defun nntp-request-list ()
  92.   "Retrieve the list of newsgroups into 'nntp-server-buffer.
  93. Returns true if successful."
  94.   (nntp/command "LIST")
  95.   (if (eq (nntp/response) 215)
  96.       ;; We don't do any text format conversion here.  It's wasted
  97.       ;; effort, since the text needs to be parsed by GNUS anyway.
  98.       (nntp/wait-for-text)))
  99.  
  100. (defun nntp-request-group (group)
  101.   "Select group GROUP.  Returns true if successful."
  102.   (nntp/command "GROUP" group)
  103.   (eq (nntp/response) 211))
  104.  
  105. (defun nntp-request-article (id)
  106.   "Retrieve article ID (either a number or a message-id) into
  107. 'nntp-server-buffer.  Returns true if successful."
  108.   (nntp/command "ARTICLE" id)
  109.   (if (eq (nntp/response) 220)
  110.       (nntp/get-text)))
  111.  
  112. (defun nntp-request-post ()
  113.   "Modify and post the current buffer.  Returns true if successful."
  114.   ;; The trick here is we want to make sure the conversation is in a
  115.   ;; sane state even if we're interrupted in middle of transmission.
  116.   ;; Right now, we just prematurely terminate the posting.  While this
  117.   ;; isn't ideal, it's better than continually adding junk to the end.
  118.   ;; The problem is NNTP doesn't let you abort a posting.
  119.   ;; XXX A better approach is to open a new connection for posting,
  120.   ;; but this is going to be slower, unless you anticipate the user by
  121.   ;; opening the connection early.
  122.   (nntp/command "POST")
  123.   (if (eq (nntp/response) 340)
  124.       (let ( (finished nil) )
  125.     (unwind-protect
  126.         (progn
  127.           (nntp/unix-to-smtp-text)
  128.           (process-send-region nntp/connection (point-min) (point-max))
  129.           (setq finished t)
  130.           (eq (nntp/response) 240))
  131.       (or finished
  132.           (process-send-string nntp/connection "\r\n.\r\n")
  133.           nil)))))
  134.  
  135. (defun nntp-retrieve-headers (sequence)
  136.   "Returns the header data for SEQUENCE in the current group.
  137. SEQUENCE is a sorted list of article numbers.
  138. XXX describe the return value."
  139.   (and sequence
  140.        (let ( (result nil) )
  141.      (message "retrieving...")
  142.      (if nntp/can-xover
  143.          (setq result (nntp/try-xover sequence)))
  144.      (if (not nntp/can-xover)
  145.          (setq result (nntp/headers sequence)))
  146.      (message "retrieving...done")
  147.      result)))
  148.  
  149. ;;;;;;;;;;;;;;;;
  150. ;;; Talking to the NNTP server.
  151.  
  152. (defun nntp/sentinel (proc delta)
  153.   (or (nntp-server-opened)
  154.       (error "NNTP connection closed.")))
  155.  
  156. (defun nntp/clear ()
  157.   ;; XXX This resynchronization is imperfect, but is probably good
  158.   ;; enough for normal use.
  159.   (chat/delete-pending-data nntp/connection))
  160.  
  161. (defun nntp/command (&rest strings)
  162.   "Start a new NNTP command."
  163.   (nntp/clear)
  164.   (process-send-string
  165.    nntp/connection
  166.    (concat (mapconcat 'identity strings " ") "\r\n")))
  167.  
  168. ;;;;;;;;;;;;;;;;
  169. ;;; Reading from the NNTP server.
  170.  
  171. (defun nntp/response ()
  172.   "Wait for an NNTP response and return the response code.  Also sets
  173. 'nntp/error-message."
  174.   ;; XXX Emacs 18.xx has a bug that turns undo back on after a gc, so
  175.   ;; we continually flush undo here.
  176.   (buffer-flush-undo nntp-server-buffer)
  177.   (chat/with-data-until-string "\n" nntp/connection
  178.     (let ( (code (string-to-int (buffer-substring (point-min)
  179.                           (+ (point-min) 3)))) )
  180.       ;; Codes 400 and up are error conditions.
  181.       (setq nntp/error-message
  182.         (and (<= 400 code)
  183.          (buffer-substring (+ (point-min) 4) (- (point-max) 2))))
  184.       code)))
  185.  
  186. (defun nntp/wait-for-text ()
  187.   "Wait for an NNTP text response.  Returns true."
  188.   (chat/wait-for-dot-crlf nntp/connection))
  189.  
  190. (defun nntp/get-text ()
  191.   "Wait for an NNTP text response and convert it to Unix text format.
  192. Returns true."
  193.   (nntp/wait-for-text)
  194.   (save-excursion
  195.     (set-buffer nntp-server-buffer)
  196.     (nntp/smtp-to-unix-text))
  197.   t)
  198.  
  199. ;;;;;;;;;;;;;;;;
  200. ;;; Handling the funny dot-CRLF text format used by SMTP/NNTP.
  201.  
  202. (defun nntp/smtp-to-unix-text ()
  203.   "Convert the current buffer from SMTP text format to Unix text
  204. format.  Modifies point.  Returns nothing."
  205.   (goto-char (point-min))
  206.   (while (not (eobp))
  207.     (if (eq (following-char) ?.)
  208.     (delete-char 1))
  209.     (end-of-line)
  210.     (if (eq (preceding-char) ?\r)
  211.     (delete-char -1))
  212.     (forward-char))
  213.   ;; Delete the last line, which had the dot-crlf terminator.
  214.   (backward-char)
  215.   (if (eq (preceding-char) ?\n)
  216.       (delete-char 1))
  217.   )
  218.  
  219. (defun nntp/unix-to-smtp-text ()
  220.   "Convert the current buffer form Unix text format to SMTP text
  221. format.  Modifies point.  Returns nothing."
  222.   (goto-char (point-min))
  223.   (while (not (eobp))
  224.     (if (eq (following-char) ?.)
  225.     (insert ?.))
  226.     (end-of-line)
  227.     (insert ?\r)
  228.     (forward-line))
  229.   ;; Add the terminator, but first insert a CRLF if necessary.
  230.   (or (bobp)
  231.       (eq (preceding-char) ?\n)
  232.       (insert "\r\n"))
  233.   (insert ".\r\n"))
  234.  
  235. ;;;;;;;;;;;;;;;;
  236. ;;; Fetch headers using XOVER.
  237.  
  238. ;; XXX We could probably try splitting a sequence into segments and
  239. ;; sending multiple XOVER commands, one for each segment.  However,
  240. ;; this is a little more expensive for the news server to process, and
  241. ;; mostly just reduces network traffic.  There isn't much difference
  242. ;; in response, unless you're in the habit of leaving 100+ article
  243. ;; gaps.  A couple hundred extra overview lines are unnoticeable on a
  244. ;; Sun SLC.
  245.  
  246. ;; XXX In general, maybe we should have a gap threshhold: if a gap is
  247. ;; larger than N, split it into two XOVER requests, but the actual
  248. ;; tradeoffs are more complex than that.  This is really a flaw in
  249. ;; XOVER; you should be able to give XOVER a monotonically increasing
  250. ;; sequence of ranges, which is something that can be processed
  251. ;; efficiently.
  252.  
  253. ;; XXX There's an unhappy synchronization problem here with C News.
  254. ;; The bounds in the active file are updated before the overview data
  255. ;; is updated, which may not happen until minutes later.  If you read
  256. ;; the active file and enter a newsgroup soon after it receives new
  257. ;; articles, then the overview fetch will leave out the new articles.
  258. ;; GNUS will wrongly conclude that the articles don't exist, mark them
  259. ;; as read, and you'll never see them.
  260.  
  261. (defun nntp/try-xover (sequence)
  262.   "Try using the XOVER command to retrieve headers."
  263.   (let ( (lo (car sequence))
  264.      (hi (car (last sequence))) )
  265.     (nntp/command "XOVER" (concat (int-to-string lo) "-" (int-to-string hi)))
  266.     (if (eq (nntp/response) 224)
  267.     (chat/with-data-until-dot-crlf nntp/connection
  268.       (nov/parse sequence))
  269.       (setq nntp/can-xover nil)
  270.       nil)))
  271.  
  272. ;;;;;;;;;;;;;;;;
  273. ;;; News overview parsing.
  274.  
  275. ;; XXX This section isn't really nntp-specific.  It probably could be
  276. ;; a separate module by itself.
  277.  
  278. ;; Small changes to this code can have large impact on performance.
  279.  
  280. ;; You'd think that using skip-chars-forward would be faster than
  281. ;; search-forward, but for some reason it ends up marginally slower.
  282. ;; I suspect it's because the setup overhead for both is about the
  283. ;; same, but the inner loop for search-forward is much more carefully
  284. ;; coded.
  285.  
  286. (defmacro nov/skip-field ()
  287.   '(search-forward "\t" eol 'end))
  288.  
  289. (defmacro nov/field ()
  290.   '(buffer-substring
  291.     (point)
  292.     (progn (nov/skip-field) (1- (point)))))
  293.  
  294. (defmacro nov/read-integer ()
  295.    "Read an integer from the current point at the buffer."
  296.    '(string-to-int
  297.      (buffer-substring (point) (progn (skip-chars-forward "0-9") (point)))))
  298.  
  299. (defun nov/parse (sequence)
  300.   "Parse the news overview data in the current buffer, and return a
  301. list of headers that match SEQUENCE (see 'nntp-retrieve-headers)."
  302.   (let ( (number nil)
  303.      (header nil)
  304.      (headers nil)
  305.      (eol nil) )
  306.     (goto-char (point-min))
  307.     (while (and sequence (not (eobp)))
  308.       (setq number (nov/read-integer))
  309.       (while (and sequence (< (car sequence) number))
  310.      (setq sequence (cdr sequence)))
  311.       (if (and sequence (eq number (car sequence)))
  312.       (progn
  313.         (setq sequence (cdr sequence))
  314.         (save-excursion
  315.           (end-of-line)
  316.           (setq eol (point)))
  317.         ;; header: [num subject from xref lines date id refs]
  318.         ;; overview: [num subject from date id refs lines chars misc]
  319.         (setq header (make-vector 8 nil))
  320.         (aset header 0 number)
  321.         (forward-char)    ; move past the "\t"
  322.         (aset header 1 (nov/field))
  323.         (aset header 2 (nov/field))
  324.         (aset header 5 (nov/field))
  325.         (aset header 6 (nov/field))
  326.         (aset header 7 (nov/field))
  327.         (nov/skip-field)
  328.         (aset header 4 (string-to-int (nov/field)))
  329.         (backward-char)
  330.         (if (search-forward "\txref: " eol t)
  331.         (aset header 3 (nov/field)))
  332.         (setq headers (cons header headers))
  333.         ))
  334.       (forward-line)
  335.       )
  336.     (setq headers (nreverse headers))
  337.     headers))
  338.  
  339. ;;;;;;;;;;;;;;;;
  340. ;;; A workaround for missing Xrefs in the overview data.
  341.  
  342. (defun nntp/add-to-hook (hook-name value)
  343.   (let ((hook nil))
  344.     (if (boundp hook-name)
  345.     (setq hook (symbol-value hook-name)))
  346.     (if (or (subrp hook)
  347.         (and hook (symbolp hook))
  348.         (and (listp hook) (eq (car hook) 'lambda)))
  349.     (setq hook (list hook)))
  350.     (or (memq value hook)
  351.     (setq hook (cons value hook)))
  352.     (set hook-name hook)))
  353.  
  354. (nntp/add-to-hook
  355.  'gnus-Article-prepare-hook
  356.  'nntp/article-get-xrefs)
  357.  
  358. (defvar gnus-current-headers nil)    ; from gnus.el
  359.  
  360. (defun nntp/article-get-xrefs ()
  361.   "Fill in the Xref value in 'gnus-current-headers, if necessary.
  362. This is meant to be called in 'gnus-Article-prepare-hook."
  363.   (or (aref gnus-current-headers 3)
  364.       (let ( (case-fold-search nil) )
  365.     (goto-char (point-min))
  366.     (search-forward "\n\n" nil 'end)
  367.     (save-restriction
  368.       (narrow-to-region (point-min) (point))
  369.       (goto-char (point-min))
  370.       (if (or (and (eq (downcase (following-char)) ?x)
  371.                (looking-at "Xref:"))
  372.           (search-forward "\nXref:" nil t))
  373.           (progn
  374.         (goto-char (match-end 0))
  375.         (forward-char)
  376.         (aset gnus-current-headers 3
  377.               (buffer-substring
  378.                (point) (progn (end-of-line) (point))))
  379.         ))))))
  380.  
  381. ;;;;;;;;;;;;;;;;
  382. ;;; Fetch headers using HEAD.
  383.  
  384. (defun nntp/headers (sequence)
  385.   (nntp/clear)
  386.   (message "request...")
  387.   (nntp/send-head-requests sequence)
  388.   (message "parsing...")
  389.   (nntp/parse-headers sequence))
  390.  
  391. (defun nntp/send-head-requests (sequence)
  392.   (while sequence
  393.     (accept-process-output)
  394.     (process-send-string
  395.      nntp/connection
  396.      (concat "HEAD " (car sequence) "\r\n"))
  397.     (setq sequence (cdr sequence))
  398.     ))
  399.  
  400. (defun nntp/parse-headers (sequence)
  401.   (let ( (headers nil)
  402.      (code nil)
  403.      (number nil) )
  404.     (while sequence
  405.       (chat/with-data-until-string "\n" nntp/connection
  406.     (setq code (string-to-int (buffer-substring (point-min)
  407.                             (+ (point-min) 4)))))
  408.       (if (eq code 221)
  409.       (chat/with-data-until-dot-crlf nntp/connection
  410.         (setq headers (cons (nntp/parse-header (car sequence)) headers)))
  411.     (forward-line))
  412.       (setq sequence (cdr sequence)))
  413.     (nreverse headers)))
  414.  
  415. (defun nntp/header-value ()
  416.   (goto-char (match-end 0))
  417.   (skip-chars-forward "\t ")
  418.   (buffer-substring
  419.    (point)
  420.    (progn
  421.      (while
  422.      (progn
  423.        (end-of-line)
  424.        (if (eq (preceding-char) ?\r)
  425.            (delete-char -1))
  426.        (forward-char)
  427.        (memq (following-char) '(?\t ? )))
  428.        (delete-char -1)
  429.        (delete-char 1)
  430.        (insert ? ))
  431.      (1- (point))))
  432.   )
  433.  
  434. (defun nntp/parse-header (number)
  435.   (let ( (header (make-vector 8 nil))
  436.      (case-fold-search t)
  437.      (fields nil) )
  438.     (aset header 0 number)
  439.     (aset header 4 0)
  440.     (while (not (eobp))
  441.       ;; header: [num subject from xref lines date id refs]
  442.       (if (not (looking-at "subject:\\|from:\\|xref:\\|lines:\\|date:\\|message-id:\\|references:"))
  443.       (forward-line)
  444.     (cond
  445.      ((eq (downcase (following-char)) ?s)
  446.       (aset header 1 (nntp/header-value)))
  447.      ((eq (downcase (following-char)) ?f)
  448.       (aset header 2 (nntp/header-value)))
  449.      ((eq (downcase (following-char)) ?x)
  450.       (aset header 3 (nntp/header-value)))
  451.      ((eq (downcase (following-char)) ?l)
  452.       (aset header 4 (string-to-int (nntp/header-value))))
  453.      ((eq (downcase (following-char)) ?d)
  454.       (aset header 5 (nntp/header-value)))
  455.      ((eq (downcase (following-char)) ?m)
  456.       (aset header 6 (nntp/header-value)))
  457.      ((eq (downcase (following-char)) ?r)
  458.       (aset header 7 (nntp/header-value)))
  459.      ))
  460.       )
  461.     header))
  462.