From 60fcfe91c518207e97eb109555e9fc682210e8c6 Mon Sep 17 00:00:00 2001 From: Katsumi Yamaoka Date: Sun, 3 Apr 2011 11:37:59 +0000 Subject: [PATCH] Fix previous commits. --- lisp/ChangeLog | 2 - lisp/nnimap.el | 5 +- lisp/nntp.el | 5 +- lisp/{network-stream.el => proto-stream.el} | 210 +++++++++----------- 4 files changed, 107 insertions(+), 115 deletions(-) rename lisp/{network-stream.el => proto-stream.el} (57%) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7ac0efd9f..7fd853e2e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,7 +1,5 @@ 2011-04-02 Chong Yidong - * proto-stream.el: Rename it to network-stream.el. - * nnimap.el (nnimap-open-connection-1): Pass explicit :end-of-command parameter to open-protocol-stream. diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 44caaed34..afdea185d 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -32,7 +32,10 @@ (eval-and-compile (require 'nnheader) - (require 'network-stream)) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (eval-when-compile (require 'cl)) diff --git a/lisp/nntp.el b/lisp/nntp.el index 0689143c4..3285da513 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -28,7 +28,10 @@ ;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (require 'network-stream)) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (require 'nnheader) (require 'nnoo) diff --git a/lisp/network-stream.el b/lisp/proto-stream.el similarity index 57% rename from lisp/network-stream.el rename to lisp/proto-stream.el index 070cd2641..45cc974e7 100644 --- a/lisp/network-stream.el +++ b/lisp/proto-stream.el @@ -1,4 +1,4 @@ -;;; network-stream.el --- open network processes, possibly with encryption +;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections ;; Copyright (C) 2010-2011 Free Software Foundation, Inc. @@ -22,14 +22,20 @@ ;;; Commentary: -;; This library provides the function `open-network-stream', which provides a -;; higher-level interface for opening TCP network processes than the built-in -;; function `make-network-process'. In addition to plain connections, it -;; supports TLS/SSL and STARTTLS connections. +;; This library is meant to provide the glue between modules that want +;; to establish a network connection to a server for protocols such as +;; IMAP, NNTP, SMTP and POP3. + +;; The main problem is that there's more than a couple of interfaces +;; towards doing this. You have normal, plain connections, which are +;; no trouble at all, but you also have TLS/SSL connections, and you +;; have STARTTLS. Negotiating this for each protocol can be rather +;; tedious, so this library provides a single entry point, and hides +;; much of the ugliness. ;; Usage example: -;; (open-network-stream +;; (open-protocol-stream ;; "*nnimap*" buffer address port ;; :type 'network ;; :capability-command "1 CAPABILITY\r\n" @@ -49,24 +55,14 @@ (proc type &optional priority-string trustfiles keyfiles)) ;;;###autoload -(defun open-network-stream (name buffer host service &rest parameters) - "Open a TCP connection to HOST, optionally with encryption. +(defun open-protocol-stream (name buffer host service &rest parameters) + "Open a network stream to HOST, possibly with encryption. Normally, return a network process object; with a non-nil :return-list parameter, return a list instead (see below). -Input and output work as for subprocesses; `delete-process' -closes it. - -NAME is the name for the process. It is modified if necessary to - make it unique. -BUFFER is a buffer or buffer name to associate with the process. - Process output goes at end of that buffer. BUFFER may be nil, - meaning that the process is not associated with any buffer. -HOST is the name or IP address of the host to connect to. -SERVICE is the name of the service desired, or an integer specifying - a port number to connect to. -The remaining PARAMETERS should be a sequence of keywords and -values: +The first four parameters, NAME, BUFFER, HOST, and SERVICE, have +the same meanings as in `open-network-stream'. The remaining +PARAMETERS should be a sequence of keywords and values: :type specifies the connection type, one of the following: nil or `network' @@ -96,6 +92,7 @@ values: or `tls' (TLS-encrypted). :end-of-command specifies a regexp matching the end of a command. + If non-nil, it defaults to \"\\n\". :success specifies a regexp matching a message indicating a successful STARTTLS negotiation. For instance, the default @@ -109,8 +106,6 @@ values: This function should take one parameter, the response to the capability command, and should return the command to switch on STARTTLS if the server supports STARTTLS, and nil otherwise." - (unless (featurep 'make-network-process) - (error "Emacs was compiled without networking support")) (let ((type (plist-get parameters :type)) (return-list (plist-get parameters :return-list))) (if (and (not return-list) @@ -118,24 +113,21 @@ values: (and (memq type '(nil network)) (not (and (plist-get parameters :success) (plist-get parameters :capability-command)))))) - ;; The simplest case: wrapper around `make-network-process'. - (make-network-process :name name :buffer buffer - :host host :service service) - (let ((work-buffer (or buffer - (generate-new-buffer " *stream buffer*"))) - (fun (cond ((eq type 'plain) 'network-stream-open-plain) - ((memq type '(nil network starttls)) - 'network-stream-open-starttls) - ((memq type '(tls ssl)) 'network-stream-open-tls) - ((eq type 'shell) 'network-stream-open-shell) - (t (error "Invalid connection type %s" type)))) - result) - (unwind-protect - (setq result (funcall fun name work-buffer host service parameters)) - (unless buffer - (and (processp (car result)) - (set-process-buffer (car result) nil)) - (kill-buffer work-buffer))) + ;; The simplest case is equivalent to `open-network-stream'. + (open-network-stream name buffer host service) + ;; For everything else, refer to proto-stream-open-*. + (unless (plist-get parameters :end-of-command) + (setq parameters (append '(:end-of-command "\r\n") parameters))) + (let* ((connection-function + (cond + ((eq type 'plain) 'proto-stream-open-plain) + ((memq type '(nil network starttls)) + 'proto-stream-open-starttls) + ((memq type '(tls ssl)) 'proto-stream-open-tls) + ((eq type 'shell) 'proto-stream-open-shell) + (t (error "Invalid connection type %s" type)))) + (result (funcall connection-function + name buffer host service parameters))) (if return-list (list (car result) :greeting (nth 1 result) @@ -143,20 +135,16 @@ values: :type (nth 3 result)) (car result)))))) -;;;###autoload -(defalias 'open-protocol-stream 'open-network-stream) - -(defun network-stream-open-plain (name buffer host service parameters) +(defun proto-stream-open-plain (name buffer host service parameters) (let ((start (with-current-buffer buffer (point))) - (stream (make-network-process :name name :buffer buffer - :host host :service service))) + (stream (open-network-stream name buffer host service))) (list stream - (network-stream-get-response stream start + (proto-stream-get-response stream start (plist-get parameters :end-of-command)) nil 'plain))) -(defun network-stream-open-starttls (name buffer host service parameters) +(defun proto-stream-open-starttls (name buffer host service parameters) (let* ((start (with-current-buffer buffer (point))) (require-tls (eq (plist-get parameters :type) 'starttls)) (starttls-function (plist-get parameters :starttls-function)) @@ -164,10 +152,11 @@ values: (capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) - (stream (make-network-process :name name :buffer buffer - :host host :service service)) - (greeting (network-stream-get-response stream start eoc)) - (capabilities (network-stream-command stream capability-command eoc)) + (stream (open-network-stream name buffer host service)) + (greeting (proto-stream-get-response stream start eoc)) + (capabilities (when capability-command + (proto-stream-command stream + capability-command eoc))) (resulting-type 'plain) starttls-command) @@ -190,9 +179,9 @@ values: ;; care about the identity of the peer. (cons "--insecure" starttls-extra-arguments)))) (setq stream (starttls-open-stream name buffer host service))) - (network-stream-get-response stream start eoc)) + (proto-stream-get-response stream start eoc)) (when (string-match success-string - (network-stream-command stream starttls-command eoc)) + (proto-stream-command stream starttls-command eoc)) ;; The server said it was OK to begin STARTTLS negotiations. (if (fboundp 'open-gnutls-stream) (gnutls-negotiate stream nil) @@ -203,13 +192,11 @@ values: ;; We didn't successfully negotiate STARTTLS; if TLS ;; isn't demanded, reopen an unencrypted connection. (unless require-tls - (setq stream - (make-network-process :name name :buffer buffer - :host host :service service)) - (network-stream-get-response stream start eoc))) + (setq stream (open-network-stream name buffer host service)) + (proto-stream-get-response stream start eoc))) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (network-stream-command stream capability-command eoc)))) + (proto-stream-command stream capability-command eoc)))) ;; If TLS is mandatory, close the connection if it's unencrypted. (and require-tls @@ -218,69 +205,70 @@ values: ;; Return value: (list stream greeting capabilities resulting-type))) -(defun network-stream-command (stream command eoc) - (when command - (let ((start (with-current-buffer (process-buffer stream) (point-max)))) - (process-send-string stream command) - (network-stream-get-response stream start eoc)))) - -(defun network-stream-get-response (stream start end-of-command) - (when end-of-command - (with-current-buffer (process-buffer stream) - (save-excursion - (goto-char start) - (while (and (memq (process-status stream) '(open run)) - (not (re-search-forward end-of-command nil t))) - (accept-process-output stream 0 50) - (goto-char start)) - ;; Return the data we got back, or nil if the process died. - (unless (= start (point)) - (buffer-substring start (point))))))) - -(defun network-stream-open-tls (name buffer host service parameters) +(defun proto-stream-command (stream command eoc) + (let ((start (with-current-buffer (process-buffer stream) (point-max)))) + (process-send-string stream command) + (proto-stream-get-response stream start eoc))) + +(defun proto-stream-get-response (stream start end-of-command) + (with-current-buffer (process-buffer stream) + (save-excursion + (goto-char start) + (while (and (memq (process-status stream) + '(open run)) + (not (re-search-forward end-of-command nil t))) + (accept-process-output stream 0 50) + (goto-char start)) + (if (= start (point)) + ;; The process died; return nil. + nil + ;; Return the data we got back. + (buffer-substring start (point)))))) + +(defun proto-stream-open-tls (name buffer host service parameters) (with-current-buffer buffer - (let* ((start (point-max)) - (use-builtin-gnutls (fboundp 'open-gnutls-stream)) - (stream - (funcall (if use-builtin-gnutls - 'open-gnutls-stream - 'open-tls-stream) - name buffer host service)) - (eoc (plist-get parameters :end-of-command))) + (let ((start (point-max)) + (stream + (funcall (if (fboundp 'open-gnutls-stream) + 'open-gnutls-stream + 'open-tls-stream) + name buffer host service)) + (eoc (plist-get parameters :end-of-command))) (if (null stream) (list nil nil nil 'plain) ;; If we're using tls.el, we have to delete the output from ;; openssl/gnutls-cli. - (when (and (null use-builtin-gnutls) eoc) - (network-stream-get-response stream start eoc) + (unless (fboundp 'open-gnutls-stream) + (proto-stream-get-response stream start eoc) (goto-char (point-min)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (let* ((capability-command (plist-get parameters :capability-command))) - (list stream - (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eoc) - 'tls)))))) + (proto-stream-capability-open start stream parameters 'tls))))) -(defun network-stream-open-shell (name buffer host service parameters) +(defun proto-stream-open-shell (name buffer host service parameters) (require 'format-spec) + (proto-stream-capability-open + (with-current-buffer buffer (point)) + (let ((process-connection-type nil)) + (start-process name buffer shell-file-name + shell-command-switch + (format-spec + (plist-get parameters :shell-command) + (format-spec-make + ?s host + ?p service)))) + parameters 'plain)) + +(defun proto-stream-capability-open (start stream parameters stream-type) (let* ((capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) - (start (with-current-buffer buffer (point))) - (stream (let ((process-connection-type nil)) - (start-process name buffer shell-file-name - shell-command-switch - (format-spec - (plist-get parameters :shell-command) - (format-spec-make - ?s host - ?p service)))))) - (list stream - (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eoc) - 'plain))) + (greeting (proto-stream-get-response stream start eoc))) + (list stream greeting + (and capability-command + (proto-stream-command stream capability-command eoc)) + stream-type))) -(provide 'network-stream) +(provide 'proto-stream) -;;; network-stream.el ends here +;;; proto-stream.el ends here -- 2.34.1