cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/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 (defvar liece-tcp-connection-type liece-tcp-default-connection-type)
  73
  74 (eval-and-compile
  75   (autoload 'open-ssl-stream "ssl")
  76   (defvar ssl-program-arguments))
  77
  78 (defcustom liece-tcp-ssl-protocol-version "3"
  79   "SSL protocol version."
  80   :type 'integer
  81   :group 'liece-tcp)
  82
  83 (defcustom liece-tcp-ssl-default-service 993
  84   "Default SSL service."
  85   :type 'liece-service-spec
  86   :group 'liece-tcp)
  87
  88 (defcustom liece-tcp-rlogin-program "rsh"
  89   "Program used to log in on remote machines.
  90 The default is \"rsh\", but \"ssh\" is a popular alternative."
  91   :type 'file
  92   :group 'liece-tcp)
  93
  94 (defcustom liece-tcp-relay-host "localhost"
  95   "Remote host address."
  96   :type 'file
  97   :group 'liece-tcp)
  98
  99 (defcustom liece-tcp-rlogin-parameters '("socket" "-q")
 100   "Parameters to `liece-tcp-open-rlogin'."
 101   :type '(repeat string)
 102   :group 'liece-tcp)
 103
 104 (defcustom liece-tcp-rlogin-user-name nil
 105   "User name on remote system when using the rlogin connect method."
 106   :type 'string
 107   :group 'liece-tcp)
 108
 109 (defvar liece-tcp-stream-alist
 110   '((network open-network-stream)
 111     (program liece-tcp-open-program-stream)
 112     (ssl liece-tcp-open-ssl-stream)
 113     (rlogin liece-tcp-open-rlogin-stream)))
 114
 115 \f
 116 ;;;###liece-autoload
 117 (defun liece-open-network-stream (name buffer host service)
 118   (let ((method
 119          (nth 1 (assq liece-tcp-connection-type
 120                       liece-tcp-stream-alist))))
 121     (or method
 122         (error "Invalid stream"))
 123     (funcall method name buffer host service)))
 124
 125 (defun liece-tcp-open-program-stream (name buffer host service)
 126   "Open a TCP connection for a service to a host.
 127 Returns a subprocess-object to represent the connection.
 128 Input and output work as for subprocesses; `delete-process' closes it.
 129 Args are NAME BUFFER HOST SERVICE.
 130 NAME is name for process.  It is modified if necessary to make it unique.
 131 BUFFER is the buffer (or `buffer-name') to associate with the process.
 132  Process output goes at end of that buffer, unless you specify
 133  an output stream or filter function to handle the output.
 134  BUFFER may be also nil, meaning that this process is not associated
 135  with any buffer
 136 Third arg is name of the host to connect to.
 137 Fourth arg SERVICE is name of the service desired, or an integer
 138  specifying a service number to connect to."
 139   (let ((proc (start-process name buffer
 140                              liece-tcp-program
 141                              host
 142                              (if (stringp service)
 143                                  service
 144                                (int-to-string service)))))
 145     (process-kill-without-query proc)
 146     ;; Return process
 147     proc))
 148
 149 (defun liece-tcp-open-ssl-stream-1 (name buffer server service extra-arg)
 150   (let* ((service (or service liece-tcp-ssl-default-service))
 151          (ssl-program-arguments (list extra-arg "-connect"
 152                                       (format "%s:%d" server service)))
 153          (process (open-ssl-stream name buffer server service)))
 154     (and process (memq (process-status process) '(open run))
 155          process)))
 156
 157 (defun liece-tcp-open-ssl-stream (name buffer server service)
 158   (if (string-equal liece-tcp-ssl-protocol-version "2")
 159       (liece-tcp-open-ssl-stream-1
 160        name buffer server service "-ssl2")
 161     (or (liece-tcp-open-ssl-stream-1
 162          name buffer server service "-ssl3")
 163         (liece-tcp-open-ssl-stream-1
 164          name buffer server service "-ssl2"))))
 165
 166 (defun liece-tcp-open-rlogin-stream (name buffer server service)
 167   "Open a connection to SERVER using rsh."
 168   (let* ((service (if (stringp service)
 169                       service
 170                     (int-to-string service)))
 171          (args `(,liece-tcp-rlogin-program
 172                  ,@(if liece-tcp-rlogin-user-name
 173                        (list "-l" liece-tcp-rlogin-user-name))
 174                  ,liece-tcp-relay-host
 175                  ,@liece-tcp-rlogin-parameters ,server ,service))
 176          (process-connection-type nil))
 177     (apply #'start-process-shell-command name buffer args)))
 178
 179 (provide 'liece-tcp)
 180
 181 ;;; liece-tcp.el ends here