Open Mash Cross Reference
mash/tcl/handoffClient/system.tcl

   # system.tcl --
   #
   #       FIXME: This file needs a description here.
   #
   # Copyright (c) 1993-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/handoffClient/system.tcl,v 1.12 2002/02/03 04:27:00 lim Exp $
  
  
  Class System
  
  
  System proc create_instance { {observer {}} } {
          global tcl_platform
          regsub -all " " $tcl_platform(os) "_" tmpOS
          if {[Class info instances System/$tmpOS]==""} {
                  global argv0
                  puts stderr "$argv0: no support for $tcl_platform(os)"
                  exit -1
          }
  
          $self set instance_ [new System/$tmpOS $observer]
  }
  
  
  System proc instance { } {
          return [$self set instance_]
  }
  
  
  System instproc init { observer } {
          $self set observer_ $observer
  }
  
  
  System instproc start_ping { addr } {
          $self instvar observer_
          $observer_ log "Trying to ping $addr"
          set chan [open "| ping $addr"]
          fconfigure $chan -blocking 0
          return $chan
  }
  
  
  System instproc ping_needs_cancel { } {
          # for unix this is true, for windows this is false
          return 1
  }
  
  
  System instproc kill { chan } {
          $self instvar observer_
          set pid [pid $chan]
          $observer_ log [exec kill -TERM $pid]
          catch {close $chan}
  }
  
  
  #System instproc ping { addr } {
  #       $self instvar observer_ ping_pid_
  #       if { ![$self ping_allowed] } {
  #               $observer_ log "PING has been disabled on this system"
  #       }
  #
  #       if [info exists ping_pid_] {
  #               $observer_ log "A ping process is currently in existence"
  #               return
  #       }
  #
  #       if { ![$self have_redirect_exec] } return
  #       $observer_ log "Trying to ping $addr"
  #       set ping_pid_ [redirect_exec "$self ping_output $observer_" \
  #                       ping $addr &]
  #}
  
 
 #System instproc ping_allowed { } {
 #       if { [$self get_option disableping]!={} } {
 #               return 0
 #       } else {
 #               return 1
 #       }
 #}
 
 
 #System instproc have_redirect_exec { } {
 #       if { [info commands redirect_exec] != "redirect_exec" } {
 #       #       $self instvar observer_
 #               $observer_ log "You seem to have an old version of mash\
 #                               \nwithout support for \"redirect_exec\"\
 #                               \n(or you are using an version of Tcl older\
 #                               than 8.0)"
 #               return 0
 #       } else {
 #               return 1
 #       }
 #}
 
 
 #System instproc ping_output { observer data } {
 #       if { [catch {$self ping_output_ $observer $data} err] } {
 #               global errorInfo
 #               puts "$err\n$errorInfo"
 #       }
 #}
 
 
 #System instproc ping_output_ { observer data } {
 #       #$self instvar observer_ ping_pid_
 #
 ##      if { [string length $data]==0 } {
 #               # we have hit the end of the output
 #               catch {$observer_ ping_done}
 #               if { [info exists ping_pid_] } { unset ping_pid_ }
 #       } else {
 #               $observer_ log $data -nonewline
 #       }
 #}
 
 
 #System instproc cancel_ping { } {
 #       $self instvar observer_ ping_pid_
 #
 #       if { ![info exists ping_pid_] } {
 #       #       $observer_ log "No PING in progress"
 #               return
 #       }
 #
 #       if { ![$self have_redirect_exec] } return
 #
 #       $observer_ log "Attempting to kill PING process (pid $ping_pid_)"
 #       redirect_exec "$observer_ log" kill -TERM $ping_pid_
 #       if { [info exists ping_pid_] } { unset ping_pid_ }
 #}
 
 
 System instproc get_default_route { } {
         if {[catch {exec netstat -rn | grep default} tmpReply]} {
                 return ""
         } else {
                 return [lindex $tmpReply 1]
         }
 }
 
 
 System instproc delete_default_route { } {
         exec route delete default
 }
 
 
 System instproc add_default_route { addr } {
         exec route add default $addr
 }
 
 
 Class System/FreeBSD      -superclass System
 Class System/BSD/OS       -superclass System
 Class System/Linux        -superclass System
 Class System/Win32        -superclass System
 Class System/Windows_95   -superclass System/Win32
 Class System/Windows_NT   -superclass System/Win32
 
 
 System/Linux instproc delete_default_route { } {
         exec route del default
 }
 
 
 System/Linux instproc add_default_route { addr } {
         exec route add default gw $addr
 }
 
 
 System/Win32 instproc get_default_route { } {
         puts "Calling route print"
         if {[catch {exec route print 0.0.0.0} tmpReply]} {
                 puts "Hmmm.... caught error when trying to query Win32 route\
                                 find?"
                 puts "$tmpReply"
         }
         puts "Done calling route print"
         if {[string first "None" $tmpReply] == -1} {
                 return [lindex $tmpReply 11]
         } else {
                 return ""
         }
 }
 
 
 System/Win32 instproc delete_default_route { } {
         puts "Calling route delete"
         exec route delete 0.0.0.0
         puts "Done calling route delete"
 }
 
 
 System/Win32 instproc add_default_route { addr } {
         puts "Calling route add"
         exec route add 0.0.0.0 mask 0.0.0.0 $addr
         puts "Done calling route add"
 }
 
 
 System/Win32 instproc ping_needs_cancel { } {
         return 0
 }