clone.pli

net plug source code

# Cloning/Gateway plugin for				 -*- tcl -*-
# NetPlug general network client in Tcl/Tk
# http://www.demailly.com/~dl/netplug.html 
#
# Copyright 1996-1997
# by Laurent Demailly - [e-mail] - http://www.demailly.com/~dl/
#
# $Id: clone.pli,v 1.3 1997/10/18 18:33:13 demailly Exp $
#
# $Log: clone.pli,v $
# Revision 1.3  1997/10/18 18:33:13  demailly
# using the new binary option of sethandler
#
# Revision 1.2  1996/10/04 10:37:09  dl
# workaround for tk4.1 limitation/bug in grid manager
#
# Revision 1.1  1996/10/02  19:28:27  dl
# Initial revision
#
#

global clone;
# keywords
regexp {[.0-9]+} {$Revision: 1.3 $} clone(version)

proc CloneInit {onoff} {
  global env host port clone netmod;
  set w .conn
  if {$onoff} {
    $w.fp.b configure -text  "New Server/Clone"
    ChangeNewConnectCmd "CloneConnect \$host \$port";
    if {!$netmod} CloneConfigEdit;
  } else {
    # restore standard command
    $w.fp.b configure  -text "New Connection";
    ChangeNewConnectCmd ;
  }
}

array set clone {
  cport 9666
  delay 1
  single 0
  auth "[CloneAsk $n $host $port]"
  keep_sofar 0
  send_sofar 0
  sofar ""
}

proc CloneAsk {n host port} {
  global clone;
 # unfortunatly 4.2's implementation of tk_messageBox is buggy...
 # (not re-entrant)
  set reply [tk_messageBox -message\
	     "Allow connection on $n from host $host port $port?"\
	     -default yes\
	     -type yesno\
	     -icon question\
	     -parent .c$n\
	     ]
  cequal $reply "yes";
}

proc CloneConfigEdit {} {
  set w .cloneconf;
  catch {destroy $w}
  toplevel $w;
  wm title $w "Clone Config...";
  label $w.l1 -text "Cloning Port (server)"
  entry $w.e1 -textvariable clone(cport) -width 6;
  checkbutton $w.c1 -text "Single Clone" -variable clone(single);
  checkbutton $w.c2 -text "Delay Connection" -variable clone(delay);
  checkbutton $w.c3 -text "Record 'SoFar' buffer" -variable clone(keep_sofar);
  checkbutton $w.c4 -text "Send 'SoFar' buffer" -variable clone(send_sofar);
  label $w.l2 -text "Authorization expression:";
  entry $w.e2 -textvariable clone(auth) -width 40;
  grid configure  $w.l1 $w.e1 -sticky w -padx 1m -pady 1m;
  grid configure  $w.c1 $w.c2 -sticky w -padx 1m -pady 1m;
  grid configure  $w.c3 $w.c4 -sticky w -padx 1m -pady 1m;
  grid configure  $w.l2 -     -sticky w -padx 1m  ;
  grid configure  $w.e2 -     -sticky w -padx 1m ;

  button $w.bok -text "Ok/Dismiss" -command "destroy $w";
  button $w.bsv -text "Save" -command clone_save;
  grid configure  $w.bok $w.bsv -sticky we -padx 2m -pady 3m
  bind $w <Return> "$w.bok invoke"
}


#################################
#   Clone Connect               #
#################################
proc CloneConnect {host port} {
  global clone conn netmod GUI;

  set n [Connect $host $port server CloneSrvCB "" "Clone " 0];
  set conn($n,sock) "";
  set clone($n,cloned) 0;
  set clone($n,clients) {};
  set clone($n,nc) 0;

  set clone($n,question) 0;

  destroy $conn($n,entry);

  set s [socket -server "CloneServer $n" $clone(cport)];

  set clone($n,srvsock) $s;

  if {$n==-1} {return -1}
  set clone($n,sport) [lindex [fconfigure $s -sockname] 2];
  defOut $n 0 "- Server listening on port $clone($n,sport) -\n" syst;
  set clone(host) $host;
  set clone(port) $port;
  
  foreach v {sofar cport auth single delay host port keep_sofar send_sofar} {
    set clone($n,$v) $clone($v);
  }

#  set clone($n,sofar) "";

  if {$GUI} {
    set w $conn($n,frame);
    frame $w.status ;
    button $w.status.quit -text "QUIT" -command "destroy .c$n";
    button $w.status.stopsrv -text "Stop Server"\
      -command "CloneShutDwnSrv $n 0";
    button $w.status.noconn -text "Prevent Conn."\
      -command "set clone($n,auth) 0;\
                defOut $n 0 \"No more connections will be granted\\n\" syst";
    button $w.status.connauth -text "Restore Conn. Auth."\
      -command "[list set clone($n,auth) $clone(auth)];\
       defOut $n 0 [list "Connections will be checked using '$clone(auth)'\n"]\
                syst";
    button $w.status.resetsf -text "Reset 'SoFar'" -command\
      "set clone($n,sofar) {}; defOut $n 0 \"SoFar buffer has been reset\\n\"\
      syst";
    checkbutton $w.status.recordrf -text "Record 'SoFar'"\
        -variable clone($n,keep_sofar);
    checkbutton $w.status.recordsf -text "Send 'SoFar'"\
        -variable clone($n,send_sofar);
    for {set i 0} {$i<4} {incr i} {grid columnconfigure $w.status $i -weight 1}
    grid $w.status.quit $w.status.stopsrv $w.status.noconn $w.status.connauth\
         -sticky ew -padx .5m;
    # we can't use grid x $w.a $w.b on 4.1... so replace "x" by foo
    label $w.status.foo41;
    grid $w.status.foo41 \
         $w.status.resetsf $w.status.recordrf $w.status.recordsf \
         -sticky ew -padx .5m;
    pack $w.status -fill x -side bottom
  }

  if {!$clone($n,delay)} {
    return [CloneDoConnect $n]
  }
  return $n;
}

proc CloneDoConnect {n} {
  global clone;
  set clone($n,clone) [DoConnect $n $clone($n,host) $clone($n,port)];
puts "clone($n,clone)=$clone($n,clone)";
  if {[cequal "" $clone($n,clone)]} {
    CloneSrvCB $n 1 "\n- Can't clone $clone($n,host) $clone($n,port) -\n";
    return -1;
  } else {
    set clone($n,cloned) 1;
    SetHandler $clone($n,clone) $n "{CloneRead $n}" 1;
    return $n;
  }
}


proc CloneShutDwnSrv {n errflag} {
  global clone conn;
  if {[info exists clone($n,srvsock)]} {
    defOut $n $errflag "Closing server\n" syst;
    close $clone($n,srvsock);
    unset clone($n,srvsock);
    # save memory
    set clone($n,keep_sofar) 0;
    set clone($n,send_sofar) 0;
    set clone($n,sofar) "";
  }
}

proc CloneServer {n sock host port} {
  global clone conn;
  set nc [incr clone($n,nc)];
  defOut $n 0 "New connection $nc from $host port $port..." syst;
  if $clone($n,auth) {
    defOut $n 0 " granted\n" syst;
  } else {
    defOut $n 0 " refused\n" error;
    catch {close $sock};
    return;
  }
  if {$clone($n,single)==1} {
    CloneShutDwnSrv $n 0;
  }
  if !$clone($n,cloned) {
    CloneDoConnect $n;
  }
  lappend clone($n,clients) $sock;
  SetHandler $sock $n "{CloneCliRead $n $nc}" 1;
  if {$clone($n,send_sofar) && ([set lg [string length $clone($n,sofar)]])} {
    defOut $n 0 \
      "sending recorded so far ($lg bytes)\n"\
      syst;
    puts -nonewline $sock $clone($n,sofar);
  }
}

proc CloneSrvCB {n errflag str} {
  global clone conn;
  defOut $n $errflag $str;
  if {$errflag} {
    puts "Clone err: $str";
    CloneClose $n $errflag;
  }
}

proc CloneClose {n errflag} {
  global conn clone;
  defOut $n $errflag "\nClosing for clone $n ($errflag)\n";
  CloneShutDwnSrv $n $errflag;
  if {$clone($n,cloned)} {
    close $clone($n,clone);
    defOut $n $errflag "Closed cloned socket $clone($n,clone)\n";
  }
  foreach c $clone($n,clients) {
    close $c;
    defOut $n $errflag "Closed client socket $c\n";
  }
  foreach el [array names irc $n,*] {unset irc($el)}
}

proc CloneRead {n errflag str} {
  global clone;
  defOut $n $errflag "> " syst;
  defOut $n $errflag $str;
  if {$errflag} {
    CloneClose $n $errflag;
    return;
  }
  if {$clone($n,keep_sofar)} {append clone($n,sofar) $str}
  foreach c $clone($n,clients) {
    puts -nonewline $c $str;
    flush $c;
  }
}

proc CloneCliRead {n nc errflag str} {
  global clone;
  defOut $n $errflag "<$nc " syst;
  defOut $n $errflag $str;
  if {$errflag} {
    CloneClose $n $errflag;
    return;
  }
  puts -nonewline $clone($n,clone) $str; flush $clone($n,clone);
}

proc clone_send {n what} {
#  global clone;
  Send $n "$what";
puts "CLONE: sent on ($n) : $what"; flush stdout;
}

proc clone_load {{fname ""}} {
  if {[cequal "" $fname]} {
    global dotdir clone;
    set fname "$dotdir/clonerc";
    uplevel #0 [list source $fname];
    return $fname;
  } else {
    uplevel #0 "source $fname"
    return $fname;
  }
}

proc clone_save {{fname ""}} {
  global clone;
  if {[cequal "" $fname]} {global dotdir;set fname "$dotdir/clonerc"}
  catch {file rename -force $fname $fname.bak}
  set f [open $fname w];
  #SAVEDVARS
  foreach v { auth cport single delay send_sofar keep_sofar sofar
  } {
    puts $f "set clone($v) [list $clone($v)]";
  }
  close $f;
  puts "save in $fname";
  return $fname;
}


# load stuff (eventually)
if {[catch clone_load err]} {
  puts stderr "Clone: error loading optional config file : $err";
}


list "Clone ..." CloneInit;