lisp/liece-tcp.el

   1 ;;; liece-tcp.el --- TCP/IP stream emulation.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Masanobu Umeda <umerin@mse.kyutech.ac.jp>
   5 ;;         Daiki Ueno <ueno@unixuser.org>
   6 ;; Created: 1999-03-16 renamed from tcp.el
   7 ;; Keywords: IRC, liece
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Notes on TCP package:
  29 ;;
  30 ;; This package provides a TCP/IP stream emulation for GNU Emacs. If
  31 ;; the function `open-network-stream' is not defined in Emacs, but
  32 ;; your operating system has a capability of network stream
  33 ;; connection, this tcp package can be used for communicating with
  34 ;; NNTP server.
  35 ;;
  36 ;; The tcp package runs inferior process which actually does the role
  37 ;; of `open-network-stream'.  The program `tcp' provided with this
  38 ;; package can be used for such purpose.  Before loading the package,
  39 ;; compile `tcp.c' and install it as `tcp' in a directory in the emacs
  40 ;; search path. If you modify `tcp.c', please send diffs to the author
  41 ;; of GNUS.  I'll include some of them in the next releases.
  42
  43 ;;; Code:
  44
  45 (require 'poe)
  46 (require 'poem)
  47
  48 (eval-when-compile
  49   (require 'liece-compat)
  50   (require 'liece-globals))
  51
  52 (defgroup liece-tcp nil
  53   "TCP/IP Emulation"
  54   :tag "TCP"
  55   :prefix "liece-"
  56   :group 'liece-server)
  57
  58 (defcustom liece-tcp-program "ltcp"
  59   "The name of the program emulating `open-network-stream' function."
  60   :type 'file
  61   :group 'liece-tcp)
  62
  63 (defcustom liece-tcp-default-connection-type 'network
  64   "TCP/IP Connection type."
  65   :type '(choice
  66           (const :tag "Network" network)
  67           (const :tag "Program" program)
  68           (const :tag "SSLeay" ssl)
  69           (const :tag "rlogin" rlogin))
  70   :group 'liece-tcp)
  71
  72 (autoload 'open-ssl-stream "ssl")
  73 (defvar ssl-program-arguments)
  74
  75 (defcustom liece-tcp-ssl-protocol-version "3"
  76   "SSL protocol version."
  77   :type 'integer
  78   :group 'liece-tcp)
  79
  80 (defcustom liece-tcp-ssl-default-service 993
  81   "Default SSL service."
  82   :type 'liece-service-spec
  83   :group 'liece-tcp)
  84
  85 (defcustom liece-tcp-rlogin-program "rsh"
  86   "Program used to log in on remote machines.
  87 The default is \"rsh\", but \"ssh\" is a popular alternative."
  88   :type 'file
  89   :group 'liece-tcp)
  90
  91 (defcustom liece-tcp-relay-host "localhost"
  92   "Remote host address."
  93   :type 'file
  94   :group 'liece-tcp)
  95
  96 (defcustom liece-tcp-rlogin-parameters '("telnet" "-8")
  97   "Parameters to `liece-tcp-open-rlogin'."
  98   :type 'list
  99   :group 'liece-tcp)
 100
 101 (defcustom liece-tcp-rlogin-user-name nil
 102   "User name on remote system when using the rlogin connect method."
 103   :type 'string
 104   :group 'liece-tcp)
 105
 106 \f
 107 ;;;###liece-autoload
 108 (defun liece-open-network-stream-as-binary
 109   (name buffer host service &optional type)
 110   (let* ((type (or type liece-tcp-default-connection-type))
 111          (method
 112           (cond ((eq type 'network)
 113                  'open-network-stream-as-binary)
 114                 ((eq type 'program)
 115                  'liece-tcp-open-program-stream-as-binary)
 116                 ((eq type 'ssl)
 117                  'liece-tcp-open-ssl-stream-as-binary)
 118                 ((eq type 'rlogin)
 119                  'liece-tcp-open-rlogin-stream-as-binary))))
 120     (funcall method name buffer host service)))
 121
 122 ;;;###liece-autoload
 123 (defun liece-open-network-stream
 124   (name buffer host service &optional type)
 125   (let* ((type (or type liece-tcp-default-connection-type))
 126          (method
 127           (cond ((eq type 'network)
 128                  'open-network-stream)
 129                 ((eq type 'program)
 130                  'liece-tcp-open-program-stream)
 131                 ((eq type 'ssl)
 132                  'liece-tcp-open-ssl-stream)
 133                 ((eq type 'rlogin)
 134                  'liece-tcp-open-rlogin-stream-as-binary))))
 135     (funcall method name buffer host service)))
 136
 137 (defun liece-tcp-open-program-stream-as-binary (name buffer host service)
 138   (as-binary-process
 139    (liece-tcp-open-program-stream
 140     name buffer host service)))
 141
 142 (defun liece-tcp-open-program-stream (name buffer host service)
 143   "Open a TCP connection for a service to a host.
 144 Returns a subprocess-object to represent the connection.
 145 Input and output work as for subprocesses; `delete-process' closes it.
 146 Args are NAME BUFFER HOST SERVICE.
 147 NAME is name for process.  It is modified if necessary to make it unique.
 148 BUFFER is the buffer (or `buffer-name') to associate with the process.
 149  Process output goes at end of that buffer, unless you specify
 150  an output stream or filter function to handle the output.
 151  BUFFER may be also nil, meaning that this process is not associated
 152  with any buffer
 153 Third arg is name of the host to connect to.
 154 Fourth arg SERVICE is name of the service desired, or an integer
 155  specifying a service number to connect to."
 156   (let ((proc (start-process name buffer
 157                              liece-tcp-program
 158                              host
 159                              (if (stringp service)
 160                                  service
 161                                (int-to-string service)))))
 162     (process-kill-without-query proc)
 163     ;; Return process
 164     proc))
 165
 166 (defun liece-tcp-open-ssl-stream-as-binary (name buffer server service)
 167   (as-binary-process
 168    (liece-tcp-open-ssl-stream
 169     name buffer server service)))
 170
 171 (defun liece-tcp-open-ssl-stream-1 (name buffer server service extra-arg)
 172   (let* ((service (or service liece-tcp-ssl-default-service))
 173          (ssl-program-arguments (list extra-arg "-connect"
 174                                       (format "%s:%d" server service)))
 175          (process (open-ssl-stream name buffer server service)))
 176     (and process (memq (process-status process) '(open run))
 177          process)))
 178
 179 (defun liece-tcp-open-ssl-stream (name buffer server service)
 180   (if (string-equal liece-tcp-ssl-protocol-version "2")
 181       (liece-tcp-open-ssl-stream-1
 182        name buffer server service "-ssl2")
 183     (or (liece-tcp-open-ssl-stream-1
 184          name buffer server service "-ssl3")
 185         (liece-tcp-open-ssl-stream-1
 186          name buffer server service "-ssl2"))))
 187
 188 (defun liece-tcp-wait-for-string (proc regexp)
 189   "Wait until string arrives in the buffer."
 190   (let ((buffer (current-buffer)))
 191     (goto-char (point-min))
 192     (while (not (re-search-forward regexp nil t))
 193       (accept-process-output proc)
 194       (set-buffer buffer)
 195       (goto-char (point-min)))))
 196
 197 (defun liece-tcp-open-rlogin-stream (name buffer server service)
 198   "Open a connection to SERVER using rsh."
 199   (let* ((service (if (stringp service)
 200                       service
 201                    (int-to-string service)))
 202          (args `(,name
 203                  ,buffer
 204                  ,liece-tcp-rlogin-program
 205                  ,@(if liece-tcp-rlogin-user-name
 206                        (list "-l" liece-tcp-rlogin-user-name))
 207                  ,liece-tcp-relay-host
 208                  ,@liece-tcp-rlogin-parameters ,server ,service))
 209          (proc (apply #'start-process args)))
 210     (save-excursion
 211       (set-buffer buffer)
 212       (liece-tcp-wait-for-string proc "^Escape") ;; XXX
 213       (beginning-of-line 2)
 214       (delete-region (point-min) (point))
 215       proc)))
 216
 217 (defun liece-tcp-open-rlogin-stream-as-binary (name buffer server service)
 218   "Open a connection to SERVER using rsh."
 219   (let* ((service (if (stringp service)
 220                       service
 221                     (int-to-string service)))
 222          (args `(,name
 223                  ,buffer
 224                  ,liece-tcp-rlogin-program
 225                  ,@(if liece-tcp-rlogin-user-name
 226                        (list "-l" liece-tcp-rlogin-user-name))
 227                  ,liece-tcp-relay-host
 228                  ,@liece-tcp-rlogin-parameters ,server ,service))
 229          (proc (as-binary-process (apply #'start-process args))))
 230     (save-excursion
 231       (set-buffer buffer)
 232       (liece-tcp-wait-for-string proc "^Escape") ;; XXX
 233       (beginning-of-line 2)
 234       (delete-region (point-min) (point))
 235       proc)))
 236
 237 (provide 'liece-tcp)
 238
 239 ;;; liece-tcp.el ends here