#
# $Id: netplug.tcl,v 5.3 1996/10/03 15:37:31 dl Exp $
#
# NetPlug
#
# An extensible, multi protocol, multi connection, network client
#
# Based on my initial tkconnect raw 'telnet' client (without telnet
# negotiation handling, line by line mode only). It includes a command history.
# and a lot a extensions... see rest of distribution
#
# This application might also serve as a tutorial/example
# of networking use with tcl7.5(6) and basic tk4.1(2) widgets...
#
# by Laurent Demailly - dl@hplyot.obspm.fr - http://hplyot.obspm.fr/~dl/
#
# latest version on http://hplyot.obspm.fr/~dl/netplug.html
#
# GNU General Public License - Author: Laurent Demailly
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation.
#
# Consult me (dl@mail.dotcom.fr) if you need other licensing terms,
# custom developments, or maybe... If you'd have a Job proposal !
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# $Log: netplug.tcl,v $
# Revision 5.3  1996/10/03  15:37:31  dl
# removed the #! ... added by instNP
#
# Revision 5.2  1996/10/03  14:03:14  dl
# dropped /bin/sh / exec wish4.2 "$0" $@ for full path (some ppl have 4.1...)
# removed debugging output left in 0.60b1
#
# Revision 5.1  1996/10/02  19:24:33  dl
# lots of change to prepare multi-win and tk-less version of netplug
# (see Changes.txt)
#
# Revision 4.1  1996/08/20  14:25:18  dl
# new NewWindow proc to create just the window and no file handlers
# Connect has new title part argument
#
# Revision 3.9  1996/08/13  14:31:54  dl
# 'don't record empty returns in history (Dary|)
# prevent re-evaluation of cmd line args at reload
#
# Revision 3.8  1996/08/13  08:43:57  dl
# if arguments to netplug are given, the main window need to be iconfied
# (and not completly withdrawn like it was)
#
# Revision 3.7  1996/08/12  20:31:41  dl
# added pageup/pagedown bindings for scrolling
#
# Revision 3.6  1996/08/12  09:01:07  dl
# give starting value to netmod (so it is inited in case of use in some *rc
# or command line). If command line args are present, keep main window
# iconified. evaluate command line arguments as Tcl with an after idle
# so windows,... are ready, and with a join so you can have multiple
# instruction separated by ";"  (like netplug 'set netmod 1;IrcConnect $irc(host) $irc(port)'
#
# Revision 3.5  1996/08/08  12:00:03  dl
# catch and display on stderr  write errors (Send)
#
# Revision 3.4  1996/08/08  09:26:44  dl
# lsort in *.pli too
#
# Revision 3.3  1996/08/07  21:10:07  dl
# sort the directories list
#
# Revision 3.2  1996/08/07  12:35:15  dl
# memory cleanup of conn array on window destroy
#
# Revision 3.1  1996/08/06  15:05:37  dl
# Interface change !
# new defOut replacing addText but with just the $n param, no more $w
# everywhere. addTxt with just $w (and no $n). no more $w in callbacks
#
# Revision 2.5  1996/08/05  19:07:49  dl
# default background like on unix
#
# Revision 2.4  1996/08/03  12:52:21  dl
# changed debug level so stdout is less floody
#
# Revision 2.3  1996/08/03  12:28:11  dl
# call the callback when the window is closed. with errflag==2
#
# Revision 2.2  1996/08/02  13:25:41  dl
# new "netmod" global variables to indicate if "shift" was pressed on buttons
#
# Revision 2.1  1996/07/30  14:24:49  dl
# new addText instead of addTxt, tag must be registered first (with new regTag)
#
# Revision 1.18  1996/07/29  20:27:40  dl
# update can be use in call back command as we now
# deregister file handler while the command is evaluated
#
# Revision 1.17  1996/07/25 17:10:28  dl
# use Netplug has ressource class for all windows
#
# Revision 1.16  1996/07/24  16:15:54  dl
# new menu button / display warning if no plugins are found
#
# Revision 1.15  1996/07/22  15:45:12  dl
# dotdir depending on the platform... more work would be needed to find
# out what goes wrong on the Mac ...
#
# Revision 1.14  1996/07/22  11:54:22  dl
# on non unix hosts use /netplug instead of ~/.netplug   (windows improvement)
# remove . from search path if dotdir exists (package installed, to avoid
# double occurence)
# evaluate additional arguments...
#
# Revision 1.13  1996/07/19  17:34:57  dl
# new socket option to Connect for already opened channels (for servers)
#
# Revision 1.12  1996/07/19  09:23:48  dl
# added errflag parameters to signal error condition (auto shown in red)
#
# Revision 1.11  1996/07/04  19:39:28  dl
# cequal repl. defined before plugins init
#
# Revision 1.10  1996/06/30 21:39:19  dl
# save some screen space with thiner scrollbar, less pad
# finally understood packer, so resizing only shrinks the message part !
#
# Revision 1.9  1996/06/28  14:27:19  dl
# using -async socket connections
#
# Revision 1.8  1996/06/27  18:42:46  dl
# now seeing the lastline without its lf, saving one line (addTxt)
#
# Revision 1.7  1996/06/26  16:01:46  dl
# added optional attrib & tag to addTxt function, so plugins can
# colorize, customize,... the display at will
#
# Revision 1.6  1996/06/24  19:40:01  dl
# new common variable : dotdir   for the rc files & such (used by modules)
#
# Revision 1.5  1996/06/21 22:42:21  dl
# couple of remaining TkNet name -> NetPlug  (tknet is already 'taken')
#
# Revision 1.4  1996/06/21 22:32:00  dl
# cleanups. added C-p / C-n to navigate in history in addition of arrows
# ...
#
# Revision 1.3  1996/06/21  13:01:12  dl
# Lots of major changes / tkconnect 1.2 : Addition of plugins support...
#
# Revision 1.2  1996/06/11  12:07:48  dl
# bug fix: wrong connect was sometime closed upond window delete of an already
#          closed connect.
#
# Revision 1.1  1996/06/05  18:16:25  dl
# Initial revision
#
#
#

# rcs kewords extraction
regexp {[.0-9]+} {$Revision: 5.3 $} version;

proc fatal_error {msg} {
  puts stderr $msg
  catch {message .message -text $msg; pack .message; tkwait window .}
  error $msg;
}

# Check the compatibility of the Tcl/Tk shell being used ...
if {[info tclversion]<7.5} {
  fatal_error "ERROR: You need Tcl version 7.5 or higher to run NetPlug";
}
if {[string compare socket [info commands socket]]} {
  fatal_error "ERROR: You need a Tcl/Tk shell with 'socket' support\
	       to run NetPlug";
}
if {![info exists tcl_platform]} {
  fatal_error "ERROR: you run a buggy pre release of Tcl7.5 or a strange\
	       version, upgrade to 7.5p1 or higher to run NetPlug";
}

switch -exact -- $tcl_platform(platform) {
  "unix" {set dotdir "~/.netplug"}
  "windows" {set dotdir "/netplug"}
  "macintosh" -
  default {set dotdir "."}
}

array set attrib {
 syst "-foreground green4"
 error "-foreground red"
}

set debug 0;
proc debug {level message} {
  global debug;
  if {$debug>=$level} {puts "(D$level) $message"; flush stdout}
}

if {![info exist GUI]} {
  if {[string compare "wm" [info commands wm]]} {
    debug 0 "Running without GUI...";
    set GUI 0;
  } else {
    debug 0 "Running with GUI...";
    set GUI 1;
  }
}

if $GUI {
# Change to 0 if you like tk4 look (screen space consuming)
if 1 {
  # tk4 look fixup, partly back to some nice tk3 look:
  option add *highlightThickness 0
  option add *Button.Pad 1
  option add *Menubutton.Pad 2
  option add *Menu.BorderWidth 2
  option add *Menu.activeBorderWidth 1
  option add *Message.padX 5
  option add *Message.padY 2
}
# change too dark windows default
option add *background #d8d8d8 widgetDefault;
}

# if tclX is here, lets use it (if not, no problem)
catch {package require Tclx}
# some usefull functions (found with tclX)

# add cequal emulation if needed
if {[string compare "cequal" [info commands "cequal"]]} {
  proc cequal {s1 s2} {expr [string compare $s1 $s2]==0}
}


# Plugins
proc PlugAdd {str proc} {
  global plugins plugin_state plugin_call GUI;
  debug 1 "Plugin '$str': callback is '$proc'";
  if {[string compare "" $proc]} {
    incr plugins;
    set plugin_state($plugins) 0;
    set plugin_call($plugins)\
	[list PlugCall $str $proc plugin_state($plugins)];
    if $GUI {
      checkbutton .pf.$plugins -relief raised \
	-variable plugin_state($plugins)\
	-text $str \
	-command "after 0 \$plugin_call($plugins)" \
      	-anchor w ;
      grid .pf.$plugins -sticky ew\
	 -column [expr ($plugins+1)%2]\
	 -row [expr ($plugins+1)/2]\
	 -padx .5m -pady .5m ; # 4.2b1 bugs on that: -ipadx .5m -ipady .5m ;
    }
  }
}

proc PlugCall {str proc valuename} {
  upvar $valuename value;
  if {[catch {eval $proc $value} res]} {
    puts stderr "Error while executing plugin ($str) '$proc' : $res !";
  }
}

proc CenterWindow {w} {
  # center trick from tk_dialog
  wm withdraw $w;
  update idletasks;
  set x [expr [winfo screenwidth $w]/2 - \
	 [winfo reqwidth $w]/2  - [winfo vrootx [winfo parent $w]]];
  set y [expr [winfo screenheight $w]/2 - \
	 [winfo reqheight $w]/2  - [winfo vrooty [winfo parent $w]]];
  wm geom $w +$x+$y ;
  wm deiconify $w ;
}

proc PlugInsInit {} {
  global plugins env GUI;

  set msg "Loading plugins... Please wait...";
  if $GUI {
    set w .msg    ;
    wm withdraw . ;
    # please wait window
    toplevel $w   ;
    wm title $w "NetPlug Message";

    message $w.m -text $msg -aspect 400 -justify center\
	         -relief ridge -cursor watch;
    pack $w.m -fill both -expand 1;
    CenterWindow $w;
    update;

    # plugins frame:
    catch {destroy .pf}
    frame .pf -relief ridge -borderwidth 2;
    menubutton .pf.mb -text "Plugins:" -indicatoron 1 -menu .pf.mb.m;
    menu .pf.mb.m -tearoff 0;
    .pf.mb.m add command -label "Reload" -command "source [info script]";
    .pf.mb.m add separator;
    .pf.mb.m add command -label "Quit" -command "destroy .";
    grid columnconfigure .pf 0 -weight 1;
    grid columnconfigure .pf 1 -weight 1;
    grid .pf.mb -;
    pack .pf -fill both -expand 1 -padx 1m -pady 1m;
#    frame .pf.fg
#    pack .pf.fg -fill both -expand 1;
  } else {
    puts $msg
  }

  if [info exist env(NETPLUG_PLUGINS)] {
    set searchdirs $env(NETPLUG_PLUGINS);
  } else {
    global dotdir;
    if {[file isdirectory $dotdir]} {
      set searchdirs [list $dotdir /usr/local/lib/netplug];
    } else {
      set searchdirs [list . /usr/local/lib/netplug];
    }
  }

  # number of plugins
  set plugins 0;

  foreach dir $searchdirs {
    set pdir $dir/plugins;
    if {[file isdirectory $dir/plugins]} {
      set dlst [lsort [glob -nocomplain -- "$pdir/*"]];
      lappend dlst "$pdir";
      debug 3 "dlst = ($dlst)";
      foreach subdir $dlst {
	if {[file isdirectory $subdir]} {
	  debug 2 "Found Plugins subdirectory $subdir";
	  regsub {^\./} $subdir {} subdir; # because mac doesnt understand ./
	  foreach plugin [lsort [glob -nocomplain -- "$subdir/*.pli"]] {
	    debug 0 "Loading $plugin";
	    if [catch {eval PlugAdd [uplevel #0 [list source $plugin]]} res] {
	      puts stderr "Error while loading $plugin : $res !";
	    }
	  }
	}
      }
    }
  }
  catch {destroy $w;}

}


PlugInsInit;

#
# Proc handler, called when the peer 'says' something
#
proc handler {mode c n cmd} {
  global skip header;
# puts stderr "-called handler $mode,$c,$n-";
  if {[catch {read $c} res]} {
    puts stderr "-Error in reading ($n/$c) : $res-";
    lappend cmd 1 "\n- Error in reading : $res -";
    DoClose $n;
    uplevel #0 $cmd;
  } elseif {[string compare "" $res]} {
#    puts "read $n/$c '[ircquote $res]'";
    set h [list handler r $c $n $cmd];
    lappend cmd 0 $res;
    fileevent $c r "";  # prevent re entry before command completion (which
    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;
  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;

  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} {
  # non blocking reads (and writes...)
  fconfigure $sock -blocking 0 ;#-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 #############
}

