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