netplug.tcl

net plug source code

    uplevel #0 $cmd;    # can call 'update')
    fileevent $c r $h;  # put back handler.
  } elseif {[eof $c]} { # because on the mac there lots of strange empty read
    puts stderr "-Connection Closed ($n/$c)-";
    lappend cmd 1 "\n- Connection Closed -";
    DoClose $n;
    uplevel #0 $cmd;
  } else {
    puts stderr "-Empty Read on $n/$c-";
  }
}

# make scroillable text widget
proc mkTxtWin {w} {
  frame $w
  text $w.msg -yscrollcommand "$w.scroll set" \
     -setgrid true -height 24 -width 80 -wrap word;
  scrollbar $w.scroll -command "$w.msg yview" -width 12;
  pack $w.scroll -side right -fill y ; # -padx 6 -pady 4 ;
  pack $w.msg -side left -fill both -expand yes; # -padx 6 -pady 4
  $w.msg configure -state disabled;
  bind $w.msg <1> "set _focus \[focus -lastfor $w.msg\];focus $w.msg"
  bind $w.msg <ButtonRelease-1> {focus $_focus}
  return $w.msg;
}

#if {![info exist txttag]} {set txttag 0}

# (re)register a tag :
proc regTag {w tagname attribs} {
  # save current tag positions
  set rg [$w tag ranges $tagname];
  # delete tag (so we start from default)
  $w tag delete  $tagname;
  # configure tag
  eval "$w tag configure $tagname $attribs";
  # restore tag positions
  if {[string compare "" $rg]} {eval "$w tag add $tagname $rg"}
}


# replaces old addText, no need to pass old $w arg
if $GUI {
proc defOut {n errflag txt {taglist ""}} {
  global conn;
  addTxt $conn($n,txt) $errflag $txt $conn($n,lastlog) $taglist;
}
} else {
proc defOut {n errflag txt {taglist ""}} {
  global conn;
  puts "M$n:$errflag [string trim $txt \n]\t$taglist";
  flush stdout;
}
}

# add some text to a text widget
# (old addTxt then addText renamed (twice) because interface changed)
proc addTxt {w errflag txt max taglist} {
  global conn;

  if {$errflag==2} {puts stderr "Err:$txt"; return}

# allow changes
  $w configure -state normal;

  if {($errflag)} {lappend taglist error}
  lappend taglist all;

  $w insert end $txt $taglist;

# keep only last N lines
  $w delete 1.0 end-${max}l;

# adjust view
  $w yview -pickplace end-2c;

# prevent edit
  $w configure -state disabled;

}

proc DoClose {n} {
 global conn;
 if {[info exists conn($n,sock)]} {
   puts "-closing $n/$conn($n,sock)-";
   if {[catch {close $conn($n,sock)} res]} {
     puts "-closing error:$res";
   }
   unset conn($n,sock);
 } else {
   puts "-closing $n request but no conn($n,sock) !-";
 }
}

proc DoCloseW {w1 w2 n cmd} {
 global conn;
 if [string compare $w1 $w2] return;  # because it's the toplevel destroy
                                      # only which matters for us
 if {[info exist conn($n,sock)]} {
   DoClose $n;
   lappend cmd 2 "\n- Window Closed -";
   uplevel #0 $cmd;
 }
 # cleanup the array
 foreach el [array names conn $n,*] {unset conn($el)}

}

# Make a new window
proc NewWindow {n title INcallback destroy_callback} {
  global conn attrib;
  set w .c$n;

  toplevel $w -class Netplug;
  wm title $w $title;
  #button $w.bq -text Quit -command terminate;
  #pack $w.bq

  set tw [mkTxtWin $w.f];
  if {[string compare "" $destroy_callback]} {
    bind $w <Destroy> $destroy_callback;
  }

  set conn($n,txt) $tw;
  set conn($n,frame) $w;
  # default is too keep 300 last lines
  set conn($n,lastlog) 300;

  # history init
  for {set i 0} {$i<50} {incr i} {
   set conn($n,hist,$i) "";
  }

  set conn($n,hist,i) 0;
  set conn($n,hist,n) 0;

  entry $w.e -textvariable conn($n,what) -width 80;

  bind $tw <ButtonRelease-2> "
      if {!\$tkPriv(mouseMoved) || \$tk_strictMotif} {
	  catch {tkEntryPaste $w.e %x}
    }
  "

  pack $w.e -fill x -padx 1m -pady .5m -side bottom;
  pack $w.f -side top -fill both -expand 1;

  bind $w.e <Return> [list sendstuff $n $INcallback];
  bind $w.e <Up>        "histmove $w.e $n 49";
  bind $w.e <Control-p> "histmove $w.e $n 49";
  bind $w.e <Down>      "histmove $w.e $n 1";
  bind $w.e <Control-n> "histmove $w.e $n 1";
  bind $w.e <Prior> "tkScrollByPages $w.f.scroll hv -1"
  bind $w.e <Next>  "tkScrollByPages $w.f.scroll hv 1"

  set conn($n,entry) $w.e;
  focus $w.e;

  foreach tag [array names attrib] {
    regTag $tw $tag $attrib($tag);
  }


}

proc DoConnect {n host port} {
    defOut $n 0 "- Connecting (async)... Please Wait... " syst;
    update
    # connect to the host
    if {[catch {set sock [socket -async $host $port]} msg]} {
      defOut $n 1 "Connect error on $host port $port : $msg -";
      return "";
    }
    defOut $n 0 "Connected to $host $port -\n" syst;
    return $sock;
}

proc SetHandler {sock n cb {binary 0}} {
  # non blocking reads (and writes...)
  fconfigure $sock -blocking 0;
  if $binary {fconfigure $sock -translation binary}
  catch {fcntl $sock KEEPALIVE 1}
  # call handler when there is something to read from the connection :
  fileevent $sock readable "handler r $sock $n $cb";
}

# Create a new connection and attach it to window
# plugins can call Connect with a call back different than default
# to do special parsing/handling of server output
proc Connect {host port {sock ""} {OUTcallback defOut} {INcallback ""}
	     {more "C"} {handle 1}} {
  global conn attrib GUI;
  set n [incr conn(n)] ;

  if $GUI {
    NewWindow $n "${more}$n: $host $port" $INcallback \
	          "DoCloseW %W .c$n $n {$OUTcallback $n}";
  }

  if {[cequal "" $sock]} {
    set sock [DoConnect $n $host $port];
    if {[cequal "" $sock]} {return -1}
  }
  
  set conn($n,sock) $sock;

  # skip configuration and fileevent stuff if handling is not requested
  if {$handle} {SetHandler $sock $n "{$OUTcallback $n}"};

  return $n;
}

proc Send {n what} {
  global conn;
  set sock $conn($n,sock);
  if [catch {puts -nonewline $sock $what; flush $sock} res] {
    puts stderr "\aWrite ERROR on $n/$sock : $res";
  }
}

proc sendstuff {n callback} {
  global conn;
  set what $conn($n,what);

  if {[catch {set sock $conn($n,sock)}]} {
    defOut $n 1 "\n- No socket for this window ! -";
    puts stderr "No socket for window $n !";
    return;
  }
  if {[cequal "" $callback]} {
    defOut $n 0 "$what\n";
    if {[catch {puts $sock $what;flush $sock} res]} {
      puts stderr "WRITE ERROR\[$n\]: $res";
      defOut $n 1 "\n- write error -";
    }
  } else {
    uplevel #0 [list $callback $n $what];
  }

# history management
  if {![string compare "" $what]} return
  set i $conn($n,hist,n);
  set conn($n,hist,$i) $what;
  set i [expr ($i+1)%50];
  set conn($n,hist,i) $i;
  set conn($n,hist,n) $i;

  set conn($n,what) {};
}

proc histmove {w n move} {
  global conn;
  set what $conn($n,what);

  set i $conn($n,hist,i);
  set conn($n,hist,$i) $what;
  set i [expr ($i+$move)%50]; 
  set conn($n,hist,i) $i;

  set what $conn($n,hist,$i);
  set conn($n,what) $what;

  $w icursor end;

}

proc CmdSet {n what} {
  global conn;
  set conn($n,what) $what;
  $conn($n,entry) icursor end;
}

# in case of errors:
#proc bgerror {mess} {
#global errorInfo;
#puts stderr "BACKGROUND ERROR : $mess";
#puts stderr "ERRORINFO: $errorInfo";
#exit 1;
#}


# main interface
proc ConnUI {w {createtoplevel 1}} {

  if {$createtoplevel} {
    catch {bind $w <Destroy> "";destroy $w}
    toplevel $w;
    wm title $w "Connect";
  } else {
    catch {destroy $w};
    frame $w -relief ridge -borderwidth 2;
  }

  frame $w.fh;
  label $w.fh.lh -text "Host:";
  entry $w.fh.host -width 30 -textvariable host;
  pack $w.fh.lh -side left;
  pack $w.fh.host -side right -fill x -expand 1 -padx 1m;

  frame $w.fp;
  label $w.fp.lp -text "Port:";
  entry $w.fp.port -width 6  -textvariable port;
  pack $w.fp.lp -side left;

  button $w.fp.b -text "New Connection";

  global connbutton;
  set connbutton $w.fp.b ;
  ChangeNewConnectCmd;

  pack $w.fp.b -side right -padx 1m;

  pack $w.fp.port -side right -fill x -expand 1 -padx 1m;

  bind $w.fh.host <Return> "focus $w.fp.port";
  bind $w.fp.port <Return> "$w.fp.b invoke";
  focus $w.fh.host;

  pack $w.fh $w.fp -fill both -expand 1 -padx 1m -pady 1m;

  bind $w.fp.b <3> "source [info script]";

  if {$createtoplevel} {bind $w <Destroy> "exit"}

}


if ![info exists conn] {
  set conn(n) 0;
}
set netmod 0;

if $GUI {
####### start of GUI only section #############
proc ChangeNewConnectCmd {{cmd "Connect \$host \$port"}} {
  global connbutton;
  $connbutton config -command $cmd;
}
proc Invoke {} {
  global connbutton;
  $connbutton invoke;
}
if {!$plugins} {
  #destroy .pf
  label .pf.warn1 -text "No Plugins Found!" -bg red -fg white;
  label .pf.warn2 -text "Check Installation?" -bg red -fg white;
  grid .pf.warn1 - -sticky ew
  grid .pf.warn2 - -sticky ew
  bind .pf.warn1 <1> "destroy .pf.warn1;destroy .pf.warn2"; 
  bind .pf.warn2 <1> "destroy .pf.warn1;destroy .pf.warn2"; 
}

wm title . "NetPlug";
if {$argc==0} {wm deiconify .} else {wm iconify .}

# general bindings for buttons,...
# [using those bindings implied the after 0 in the -command for checkbuttons]
bind . <Shift-1> "set netmod 1";
bind . <1> "set netmod 0";

ConnUI .conn 0;
pack .conn -fill x -expand 1 -padx 1m -pady 1m ;
####### end of   GUI only section #############
} else {
####### start of NON GUI only section #############
proc ChangeNewConnectCmd {{cmd "Connect \$host \$port"}} {
  global conncmd;
  set conncmd $cmd;
}
proc Invoke {} {
  global conncmd;
  uplevel #0 $conncmd;
}
if {!$plugins} {
  puts stderr "STRANGE: No Plugins Found! Check Installation?";
}
set host ""
set port ""
####### end of   NON GUI only section #############
}

# prepare execution of command line arguments:

if {$argc>0} {
  after idle [join $argv " "]
  # prevent re-evaluation at reload
  set sv_argc $argc;
  set argc -1;
}

puts stderr "-sourced ok!-";

if !$GUI {
####### start of NON GUI only section #############
  proc bgerror msg {
   global errorInfo
   puts "BG ERROR: $msg";
   puts "STACK TRACE: $errorInfo";
  }
  vwait forever
####### end of   NON GUI only section #############
}