Open Mash Cross Reference
mash/tcl/net/tcp.tcl

   # tcp.tcl --
   #
   #       FIXME: This file needs a description here.
   #
   # Copyright (c) 1997-2002 The Regents of the University of California.
   # All rights reserved.
   #
   # Redistribution and use in source and binary forms, with or without
   # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  #
  # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/net/tcp.tcl,v 1.13 2002/02/03 04:28:06 lim Exp $
  
  
  #
  # A base class for TCP client and server connections.
  #
  Class TCP
  
  #
  # A base class for TCP server connections.
  #
  Class TCP/Server -superclass TCP
  
  #
  # A base class for TCP client connections.
  #
  Class TCP/Client -superclass TCP
  
  TCP public destroy {} {
          $self close
          $self next
  }
  
  #
  # virtual method called when far end closes
  #
  TCP public shutdown {} {
  }
  
  
  TCP public set_binary { {flag 1} } {
          $self instvar chan_
          if { $flag } {
                  fconfigure $chan_ -translation {binary binary}
          } else {
                  fconfigure $chan_ -translation {auto auto}
          }
  }
  
  
  TCP public open { chan {blocking 0} } {
          $self instvar chan_
          #FIXME should do async open
          set chan_ $chan
          fileevent $chan_ readable "$self readable"
          if { $blocking } {
                  fconfigure $chan_ -blocking true
          } else {
                  fconfigure $chan_ -blocking false
          }
  }
  
  
  TCP public is_open { } {
          $self instvar chan_
          if { [info exists chan_] && ![eof $chan_] } {
                  return 1
          }
          return 0
  }
  
  
  TCP public close {} {
          $self instvar chan_
          if [info exists chan_] {
                  close $chan_
                  unset chan_
          }
  }
 
 
 TCP public channel {} {
         $self instvar chan_
         if [info exists chan_] { return $chan_ } else { return "" }
 }
 
 
 TCP private readable {} {
         $self instvar chan_
         set cnt [gets $chan_ s]
         if { $cnt < 0 } {
                 if [eof $chan_] {
                         $self close
                         $self shutdown
                         #FIXME how to delete ourself?
                 }
                 return
         }
         # count of zero might be single newline (FIXME which is stripped...)
         if { $cnt >= 0 } {
                 $self recv $s
         }
 }
 
 
 TCP public send s {
         $self instvar chan_
         puts -nonewline $chan_ $s
         #FIXME
         flush $chan_
 }
 
 
 #
 # FIXME hack since otcl methods can't deal with binary strings
 #
 TCP public send_data {} {
         $self instvar chan_ data_
         puts -nonewline $chan_ $data_
         #FIXME
         flush $chan_
 }
 
 
 TCP public sendline s {
         $self instvar chan_
         puts $chan_ $s
         #FIXME
         flush $chan_
 }
 
 
 # The application must redefine this method in a sub-class
 # It is invoked every time a line is received from the socket
 TCP public recv s {
 }
 
 
 TCP/Client public init args {
 }
 
 
 #
 # Open a TCP connection to the Internet host <i>host</i>
 # on the TCP port <i>port</i>
 #
 TCP/Client public open { host port {blocking 0} } {
         $self instvar chan_
         #FIXME should do async open
         set chan_ [socket $host $port]
         fileevent $chan_ readable "$self readable"
         if { $blocking } {
                 fconfigure $chan_ -blocking true
         } else {
                 fconfigure $chan_ -blocking false
         }
 }
 
 
 #
 # Open a TCP listen socket on port <i>port</i>.
 # When a client connects to this port, the virtual method
 # TCP/Server::create_channel is called to create
 # a TCP object.
 # <p>
 # The <i>create_channel</i> argument can either be the
 # name of a class (typically subclassed from TCP) --
 # the TCP/Server object will create an object of that
 # class whenever it receives a TCP connection. From
 # that point on, this object can communicate with
 # the remote side using the normal TCP API.
 # Alternatively, the <i>create_channel</i> argument
 # may be a command to invoke when the TCP/Server
 # object receives a connection. The command must take
 # a Tcl channel id as an argument.
 # <p>
 # Finally, you may simply not specify the <i>create_channel</i>
 # argument, and redefine the <i>create_channel</i> method in a
 # subclass of TCP/Server
 #
 TCP/Server public open { port {create_channel {}} } {
         $self instvar chan_ client_class_ create_channel_proc_
         #FIXME should do async open
         set chan_ [socket -server "$self accept" $port]
         if { $create_channel != {} } {
                 # first check if this is a class name
                 if { [Class info instances $create_channel]!="" } {
                         set client_class_ $create_channel
                 } else {
                         set create_channel_proc_ $create_channel
                 }
         }
 }
 
 
 TCP/Server public close { } {
         $self instvar client_class_ create_channel_proc_
         if [info exists client_class_] {
                 unset client_class_
         }
 
         if [info exists create_channel_proc_] {
                 unset create_channel_proc_
         }
 
         $self next
 }
 
 
 TCP/Server private accept { chan host port } {
         set o [$self create_channel $chan]
 }
 
 
 #
 # The default create_channel method creates a channel
 # object whenever the server receives a TCP connection
 # Look at <i>TCP/Server::open</i> for details.
 #
 TCP/Server private create_channel { chan } {
         $self instvar client_class_ create_channel_proc_
         if [info exists create_channel_proc_] {
                 eval $create_channel_proc_ $chan
         } elseif [info exists client_class_] {
                 set o [new $client_class_]
                 $o open $chan
         } else {
                 error "must redefine TCP/Server::create_channel in a subclass\
                                 \nor specify a channel creation mechanism in\
                                 TCP/Server::open"
         }
 }