home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / nntp-post-bg.el < prev    next >
Encoding:
Text File  |  1995-03-25  |  8.7 KB  |  218 lines
  1. ;; Allows GNUS to make posts in the background (via a second NNTP connection.)
  2. ;; By Jamie Zawinski <jwz@lucid.com> 6-jun-93
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  19. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;; This makes it possible for GNUS to post new articles by opening a second
  22. ;; (or third, or fourth...) NNTP connection and posting on that asynchronously,
  23. ;; instead of tying up the primary NNTP connection until the post completes.
  24. ;; This is nice because on some servers, posting a new article takes an 
  25. ;; obscenely long time.  Drawbacks of using this are slightly less feedback
  26. ;; about whether your post has succeeded (you might exit emacs before you got
  27. ;; to see the diagnostics) and that opening these subsequent connections uses
  28. ;; more resources on the NNTP server (and I suppose some servers might limit
  29. ;; the number of connections as well.)
  30. ;;
  31. ;; It would be nice if, instead of having to decide whether to post in the
  32. ;; foreground or background up front, we could arrange so that ^G during a
  33. ;; foreground post turned it into a background post (the zmacs mailer did
  34. ;; this, it was swell) but that's hard, because by the time a foreground post
  35. ;; has begun, the primary nntp connection is already wedged.  To do this, we'd
  36. ;; have to make the primary connection be the posting connection (the one that
  37. ;; will get nuked when the post completes) and install a new primary
  38. ;; connection.  Actually I guess that's not so hard after all.
  39.  
  40. (require 'nntp)
  41.  
  42. ;; It probably wouldn't be too hard to make this work; 
  43. ;; if you do it send me the changes.
  44. (if (string-match "flee" nntp-version)
  45.     (error "nntp-post-bg doesn't work with flee's version of nntp.el"))
  46.  
  47. (defvar nntp-post-background 'query
  48.   "If t, each post will make a new connection to the NNTP server.
  49. This means that you don't have to wait for the post to complete to
  50. continue reading articles.  If nil, posts will be made on the same
  51. connection.  If any other value, you will be asked.")
  52.  
  53. (or (fboundp 'buffer-disable-undo)
  54.     (fset 'buffer-disable-undo 'buffer-flush-undo))
  55.  
  56. (defun nntp-open-server-internal (host &optional service)
  57.   "Open connection to news server on HOST by SERVICE (default is nntp)."
  58.   (save-excursion
  59.     ;; Use TCP/IP stream emulation package if needed.
  60.     (or (fboundp 'open-network-stream)
  61.     (require 'tcp))
  62.     ;; Initialize communication buffer.
  63.     ;; jwz: changed to use generate-new-buffer to support multiple connections.
  64.     (if (and nntp-server-buffer (buffer-name nntp-server-buffer))
  65.     (kill-buffer nntp-server-buffer))
  66.     (setq nntp-server-buffer (generate-new-buffer " *nntpd*"))
  67.     (set-buffer nntp-server-buffer)
  68.     (buffer-disable-undo (current-buffer))
  69.     (erase-buffer)
  70.     (kill-all-local-variables)
  71.     (setq case-fold-search t)        ;Should ignore case.
  72.     (setq nntp-server-process
  73.       (open-network-stream "nntpd" (current-buffer)
  74.                    host (or service "nntp")))
  75.     (setq nntp-server-name host)
  76.     ;; It is possible to change kanji-fileio-code in this hook.
  77.     (run-hooks 'nntp-server-hook)
  78.     ;; Kill this process without complaint when exiting Emacs.
  79.     (process-kill-without-query nntp-server-process)
  80.     ;; Return the server process.
  81.     nntp-server-process
  82.     ))
  83.  
  84. (defvar nntp-post-bg-state) ;local to buffer of bg process
  85. (defvar nntp-post-bg-source) ;the buffer of the message to post (modified)
  86. (defvar background-post-queue nil) ;pending procs
  87.  
  88. (defun nntp-request-post ()
  89.   "Post a new news article from the text of the current buffer."
  90.   (cond
  91.    ((or (eq nntp-post-background t)
  92.     (and nntp-post-background (y-or-n-p "Post in background? ")))
  93.     (let ((nntp-status-string nil)
  94.       (nntp-server-process nil)
  95.       (nntp-server-buffer nil)
  96.       (message (current-buffer)))
  97.       (message "Opening NNTP connection for posting...")
  98.       (or (nntp-open-server gnus-nntp-server gnus-nntp-service)
  99.       (error "couldn't open new NNTP connection for posting."))
  100.       (set-process-filter nntp-server-process 'nntp-post-bg-filter)
  101.       (message "Opening NNTP connection for posting...  encoding text...")
  102.       (save-excursion
  103.     (set-buffer (generate-new-buffer " *bg-post-text*"))
  104.     (erase-buffer)
  105.     (buffer-disable-undo (current-buffer))
  106.     (insert-buffer message)
  107.     (nntp-encode-text)
  108.     (setq message (current-buffer)))
  109.       (save-excursion
  110.     (set-buffer message)
  111.     (rename-buffer (let ((b (generate-new-buffer " *bg-post*")))
  112.              (prog1 (buffer-name b) (kill-buffer b)))))
  113.       (save-excursion
  114.     (set-buffer nntp-server-buffer)
  115.     (set (make-local-variable 'nntp-post-bg-state) 'post)
  116.     (set (make-local-variable 'nntp-post-bg-source) message)
  117.     (setq background-post-queue
  118.           (cons nntp-server-process background-post-queue))
  119.     (nntp-send-command nil "POST"))
  120.       (message "Posting will proceed in background.")))
  121.    (t
  122.     (message "NNTP: awaiting POST connection...")
  123.     (if (nntp-send-command "^[23].*\r$" "POST")
  124.     (progn
  125.       (message "NNTP: got POST connection; encoding text...")
  126.       (nntp-encode-text)
  127.       (message "NNTP: got POST connection; sending text...")
  128.       (nntp-send-region-to-server (point-min) (point-max))
  129.       ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
  130.       ;;  appended to end of the status message.
  131.       (message "NNTP: text sent; awaiting response...")
  132.       (prog1
  133.           (nntp-wait-for-response "^[23].*$")
  134.         (message "NNTP: post complete.")))))))
  135.  
  136. (defun nntp-post-bg-error (proc error)
  137.   (let ((buffer (process-buffer proc)))
  138.     (save-excursion
  139.       (set-buffer buffer)
  140.       (setq nntp-post-bg-state 'error)
  141.       (kill-buffer nntp-post-bg-source)
  142.       (delete-process proc)
  143.       (kill-buffer buffer)))
  144.   (setq background-post-queue (delq proc background-post-queue))
  145.   (if error (error error)))
  146.  
  147. (defun nntp-post-bg-filter (proc string)
  148.   (save-excursion
  149.     (let ((buffer (process-buffer proc)))
  150.       (set-buffer buffer)
  151.       (goto-char (point-max))
  152.       (insert string)
  153.       (cond
  154.        ((eq nntp-post-bg-state 'post)
  155.     ;; have sent POST command, waiting for response
  156.     (cond ((not (re-search-backward "^[2345].*\r$")) ; no response yet
  157.            nil)
  158.           ((looking-at "[23]")    ; ok, now send text
  159.            (erase-buffer)
  160.            (message "NNTP: got POST connection; sending text...")
  161.            ;; This synchronously sends the entire post.  It may be
  162.            ;; that this will block for an unacceptably long time on
  163.            ;; some servers, while waiting for the streams to drain.
  164.            ;; It might therefore be worthwhile to write an async
  165.            ;;version of nntp-send-region-to-server.
  166.            (save-excursion
  167.          (set-buffer nntp-post-bg-source)
  168.          (let ((nntp-server-process proc)
  169.                (nntp-server-buffer buffer)
  170.                (ok nil))
  171.            (unwind-protect
  172.                (progn
  173.              (nntp-send-region-to-server (point-min) (point-max))
  174.              (setq ok t))
  175.              (or ok (nntp-post-bg-error proc nil)))))
  176.            (message "NNTP: text sent; awaiting response in background.")
  177.            (setq nntp-post-bg-state 'sent))
  178.           (t
  179.            (nntp-post-bg-error proc
  180.         (concat "POST failed: "
  181.          (buffer-substring (point) (progn (end-of-line) (point))))))))
  182.        ((eq nntp-post-bg-state 'sent)
  183.     ;; have sent text of message, waiting for response
  184.     (cond ((not (re-search-backward "^[2345].*\r$")) ; no response yet
  185.            nil)
  186.           ((looking-at "[23]")    ; ok, we're done.
  187.            (erase-buffer)
  188.            (setq nntp-post-bg-state 'closed)
  189.            (set-buffer (other-buffer))
  190.            (delete-process proc)
  191.            (kill-buffer buffer)
  192.            (setq background-post-queue (delq proc background-post-queue))
  193.            (message "Background post complete!")
  194.            )
  195.           (t
  196.            (nntp-post-bg-error proc
  197.         (concat "POST failed: "
  198.          (buffer-substring (point) (progn (end-of-line) (point))))))))
  199.        (t
  200.     (error "internal error: nntp-post-bg-state is %s"
  201.            nntp-post-bg-state))))))
  202.  
  203. (defun nntp-post-bg-maybe-warn-about-pending-posts ()
  204.   (if (null background-post-queue)
  205.       nil
  206.     (or (if (cdr background-post-queue)
  207.         (yes-or-no-p
  208.          (format "There are %d background posts in progress; exit anyway? "
  209.              (length background-post-queue)))
  210.       (yes-or-no-p
  211.        "There is a background post in progress; exit anyway? "))
  212.     (error ""))))
  213.  
  214. (if (fboundp 'add-hook)
  215.     (add-hook 'kill-emacs-hook 'nntp-post-bg-maybe-warn-about-pending-posts))
  216.  
  217. (provide 'nntp-post-bg)
  218.