netplug.tcl

net plug source code

#
# $Id: netplug.tcl,v 5.6 1997/10/27 05:07:56 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 - [e-mail] - http://www.demailly.com/~dl/
#
# latest version on http://www.demailly.com/~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 ([e-mail]) if you need other licensing terms,
# custom developments,...
#
# 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.6  1997/10/27 05:07:56  dl
# make selection visible in text widget on windows and mac
# (by putting the focus in the widget and putting it
# back on release)
# make past with button-2 work (unix)
#
# Revision 5.5  1997/10/18 18:26:09  demailly
# defining netpcopy instead of using unsupported0, tcl8 version
# new adress
#
# Revision 5.4  1997/04/24 22:17:36  dl
# bug fix (windows) [list command...] was needed for reload because info script
# can return string with special chars (\...)
#
# 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.6 $} 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";
}

# Check if we have "unsupported0" (binary copy)
if {[string compare [info command unsupported0] unsupported0]} {
    # nb: we can not use fcopy because it does not have
    #     the same semantic
    proc netpcopy {in out {size ""}} {
	if {[string compare $size ""]} {
	    set str [read $in $size];
	} else {
	    set str [read $in];
	}
	puts -nonewline $out $str;
	string length $str;
    }
} else {
    proc netpcopy args {uplevel unsupported0 $args}
}

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 [list 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