irc.pli

net plug source code

# IRC plugin for				 -*- tcl -*-
# NetPlug general network client in Tcl/Tk
# http://www.demailly.com/~dl/netplug.html 
#
# Copyright 1994-1997
# by Laurent Demailly - [e-mail] - http://www.demailly.com/~dl/
#
# You are hereby granted a right to USE this software at no cost but
# WITHOUT ANY WARRANTY provided that you respect the conditions stated
# here [if you don't just delete this file].
#
# 1) This is a BETA version,
#    redistribution without permission from the author is forbidden.
#
# 2) You must NOT modify this file in any way,
#
#  + Any customisation can be done through your ircrc or irc(autoload)'ed
#    scripts. Changing this file will just make upgrade painfull
#    (not counting License Violation for those who cares).
#  + If you find a bug, that would need to be fixed in this file,
#    Please report to the author:  [e-mail]
#
# $Id: irc.pli,v 5.9 1997/10/27 07:39:43 dl Exp dl $
#
# $Log: irc.pli,v $
# Revision 5.9  1997/10/27 07:39:43  dl
# updated ctcp src url
#
# Revision 5.8  1997/10/27 05:05:29  dl
# purge is now bound on ctrl-shift-c instead of ctrl-c (== copy)
# <1> is + binded so the focus works
#
# Revision 5.7  1997/10/18 18:19:02  demailly
# tcl8's menu update
# unsupported0 -> netpcopy
# dcc fixes
# email fixes
#
# Revision 5.6  1997/06/18 01:02:27  demailly
# use format %u for clock clicks (from within the plugin we have sometime
#  negative values otherwise). partly fixed  help for dcc.
#
# Revision 5.5  1997/05/17 13:23:31  dl
# switched to 0.61
#
# Revision 5.4  1997/04/25 23:11:43  dl
# workaround tcl8/win95 bug where our ip was found to be 0 by fconfigure...
#
# Revision 5.3  1997/03/22 16:24:11  dl
# small font/bold bug fix
#
# Revision 5.2  1996/10/02  19:31:52  dl
# release string was wrong
#
# Revision 5.1  1996/10/02  19:27:43  dl
# bug fixes, use of cequal,... lots of change to prepare multi-win and tk-less
# version of netplug (see Changes.txt)
#
# Revision 4.51  1996/09/18  15:00:51  dl
# new PASS handling (gui,...). bug fix: init irc($n,server). added menu_cancel
# flag and auto cancel of reconnects if menu item is selected.
#
# Revision 4.50  1996/09/18  11:03:06  dl
# pong handling. ping server when socket is idle (server_ping).
# do not ignore duplicates if we said something in between
# better unknown output display (use raw buffer)
#
# Revision 4.49  1996/09/16  15:31:42  dl
# typo irc(keep_dupl) and irc(show_once)
#
# Revision 4.48  1996/09/16  15:29:00  dl
# added some flood control and show away once like feature
#
# Revision 4.47  1996/09/16  13:50:02  dl
# added finger var, ctcp idle and finger. auto away removed only on msg
# (public or private). manual away can behave like auto. fix in /countlog
# added /kill and /squit
#
# Revision 4.46  1996/09/06  11:52:57  dl
# added COUNTLOG alias. resetlog uses open instead of exec rm to reset log
# to 0 bytes file. use logmsgn value if not empty when opening new log
#
# Revision 4.45  1996/09/06  11:23:23  dl
# auto update tags on window resize
#
# Revision 4.44  1996/09/06  10:34:33  dl
# bug fixes in fastmode. new irc(lastlog) and /setlastlog alias. more handy
# shortcut aliases. changed topic into smart alias. improved kill path
# shortener (thx yegg)
#
# Revision 4.43  1996/08/21  11:33:51  dl
# new server_notice tag/attrib. using -wrap none for best server notice display
# more tuneup / suppressions in default server_notice display
#
# Revision 4.42  1996/08/20  19:26:23  dl
# server_notices improvements. kill path shortener
#
# Revision 4.41  1996/08/20  14:27:58  dl
# using title new arg of netplug's Connect. bug fix in autoexec.
# autoreconnect off by default. new /showlog and menu item (using new file pli)
#
# Revision 4.40  1996/08/19  17:38:54  dl
# allow expressions in tags. get the right width for right justification
# independently from font width. new nickquery flag for SAY in /query nick
#
# Revision 4.39  1996/08/19  15:46:58  dl
# version increase, more log shortening
#
# Revision 4.38  1996/08/19  15:41:21  dl
# numerics categ improvements. kick bug fix. some log cut for brievety sake
#
# Revision 4.36  1996/08/19  14:34:46  dl
# new oper command, new right justified tab used by new default numerics
# handling.
#
# Revision 4.35  1996/08/19  13:40:47  dl
# pop up menu, new bindings alt-space,m,d
#
# Revision 4.34  1996/08/19  10:28:12  dl
# channel menus in synch. autojoin possible for kicks too and replaces invite
# join, works with keys too. IU_Emergency hot key customizable binding.
# smarter invite command. new irc(remove_away) when msg flag.
# irc(connections) list. cycle command.
#
# Revision 4.33  1996/08/16  16:45:20  dl
# invite, wallop, new bindings, multi-channel join aware...
#
# Revision 4.32  1996/08/14  23:27:19  dl
# keys management in chanlist and menu. ^ chars not parsed in important
# message part (whois...) (unlike ircII users, we don't get fooled)
# more workaround against tk bug
# initial dest set to "*" so the menu is more visible. record the cur key.
#
# Revision 4.31  1996/08/14  18:06:48  dl
# bug fix in MODE alias, now smarter. you can prevent alias subst by //cmd
# more numerics
#
# Revision 4.29  1996/08/14  15:28:15  dl
# more numerics (stats,...).  bug fix: one line menus exec was not done
# when using irc_add_* (changed only in BuilMenus at first)
#
# Revision 4.28  1996/08/14  14:08:31  dl
# improvement in DCC (no more '0' burps in slider bar)
# added CVERS alias (ctcp <> version)
#
# Revision 4.26  1996/08/13  15:03:34  dl
# ^c to purge. error catching. lots of new numerics parsed. added some
# update (so ^c always works). auto nick bug fix. idle time parsing.
# undernet/TS parsing. nick & channel menus action takes now only 1 line
# NEW: away button and dest: menu ! (irc(destlist) for customization)
# ...
#
# Revision 4.25  1996/08/12  20:49:49  dl
#  new numerics, exec tag fix, improved packing order in status, ... 50th rel!
#
# [...Long log of changes cut...]
#
# Revision 1.1  1996/06/21  13:01:55  dl
# Initial revision
#

global irc;

# keywords
regexp {[.0-9]+} {$Revision: 5.9 $} irc(version)
set irc(date) [string trim {$Date: 1997/10/27 07:39:43 $} \$\ ]
regsub -all {:} $irc(date) {.} irc(date);
set irc(load) [clock format [clock seconds]]
regsub -all {:} $irc(load) {.} irc(load);

if {![info exist irc(first)]} {set irc(first) 1} 
# open connections list
if {![info exist irc(connections)]} {set irc(connections) ""} 

proc IrcInit {onoff} {
  global env host port irc netmod;
  if {$onoff} {
    ChangeNewConnectCmd "IrcConnect \$host \$port";
    if {$irc(first)} {
      set irc(first) 0;
      if {[info exists env(IRCPORT)]} {
        set port $env(IRCPORT);
      } else {
        set port 6667;
      }
      if {[info exists env(IRCSERVER)]} {
        set host $env(IRCSERVER);
      } else {
        set host "irc";
      }
      set irc(host) $host;
      set irc(port) $port;
      if {[info exists env(LOGNAME)]} {
        set irc(logname) $env(LOGNAME);
      } else {
        set irc(logname) "unknown";
      }
      if {[info exists env(IRCNICK)]} {
        set irc(nick) $env(IRCNICK);
      } else {
        set irc(nick) $irc(logname);
      }
      if {[info exists env(IRCNAME)]} {
        set irc(name) $env(IRCNAME);
      } else {
        set irc(name) "*name not set*";
      }
      if {[info exists env(IRCPASS)]} {
        set irc(pass) $env(IRCPASS);
      } else {
        set irc(pass) "";
      }
    } else {
      if {$netmod && (![cequal "" $host])} return;
      set host $irc(host);
      set port $irc(port);
    }
    if {!$netmod} IrcConfigEdit;
  } else {
    # restore standard command
    ChangeNewConnectCmd ;
  }
}

proc IrcConfigEdit {} {
  set w .ircconf;
  catch {destroy $w}
  toplevel $w;
  wm title $w "Irc Config...";
  label $w.l1 -text " ( Login Name";
  entry $w.e1 -textvariable irc(logname) -width 9;
  label $w.l2 -text "Nickname";
  label $w.ls -text ")";
  entry $w.e2 -textvariable irc(nick) -width 9;
  label $w.lp -text "Password (generally not needed/empty) :";
  entry $w.ep -textvariable irc(pass) -width 50;
  label $w.l3 -text "Full Name :";
  entry $w.e3 -textvariable irc(name) -width 50;
  label $w.l4 -text "Finger info (enter your email for instance) :";
  entry $w.e4 -textvariable irc(finger) -width 50;
  grid configure  $w.l2  $w.e2  $w.l1  $w.e1 $w.ls -sticky w -padx 1m -pady 1m;
  grid configure  $w.lp - - - - -sticky w -padx 1m  ;
  grid configure  $w.ep - - - - -sticky w -padx 1m ;
  grid configure  $w.l3 - - - - -sticky w -padx 1m  ;
  grid configure  $w.e3 - - - - -sticky w -padx 1m ;
  grid configure  $w.l4 - - - - -sticky w -padx 1m  ;
  grid configure  $w.e4 - - - - -sticky w -padx 1m ;

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

proc IrcMenuAdd {n menu what} {
  eval $menu add $what;
}

proc IrcBuildChanMenus {} {
  global irc;
  foreach n $irc(connections) {IrcBuildChanMenu $n}
}

# Channel menu
proc IrcBuildChanMenu {n} {
  global conn irc;

  set wm $conn($n,frame).status.chan.m;
  catch {destroy $wm};
  menu $wm ;
  foreach chanl $irc(chanlist) { 
    # WARNING: elems in chanlist must be LISTS (of 1 or two elements)
    $wm add command -label [join $chanl] -command "irc_join $n $chanl"; 
  }
  puts "C$n rebuilt channel menu";
}

# All menus
proc IrcBuildMenus {n} {
  global conn irc;
# Main command menu:
  set wm $conn($n,frame).status.mb.m;
  catch {destroy $wm};
  menu $wm ;
  foreach menuitem $irc(menulist) {
    IrcMenuAdd $n $wm $menuitem;
  }
# duplicate it for popup:
  set wm .c$n.popupm;
  catch {destroy $wm};
#  menu $wm -transient 1 -tearoff 0 ;
  menu $wm -tearoff 0 ;
  foreach menuitem $irc(menulist) {
    IrcMenuAdd $n $wm $menuitem;
  }
# Nick menu
  set wm $conn($n,frame).status.nick.m;
  catch {destroy $wm};
  menu $wm ;
  foreach nick $irc(nicklist) {
    $wm add command -label $nick -command [list IrcDo $n "/nick $nick"]; 
  }
# Channel menu
  IrcBuildChanMenus ;# $n;
# Dest menu
  set wm $conn($n,frame).status.dest.m;
  catch {destroy $wm};
  menu $wm ;
  foreach what $irc(destlist) {
    $wm add command -label $what -command [list IrcDoN $n /$what];
  }
}

proc irc_join {n chan {more ""}} {
  global irc;
  if {[cequal "" $more]} {
    set what $chan;
  } else {
    set what "$chan $more";
  }
  set dest [lindex [split $chan ","] 0];
  irc_fshow $n "+++ default destination is now $dest \[JOIN $what\]" \
                system;
  set irc($n,curchan) $dest;
  set irc($n,curkey) $more;
  set irc($n,nickquery) 0;
  irc_send $n "JOIN $what";
}

proc irc_add_nick {n nick} {
 global conn irc; # keep case sensitivity for nick
 if {[lsearch -exact $irc(nicklist) $nick]==-1} {
   lappend irc(nicklist) $nick
   $conn($n,frame).status.nick.m add command -label $nick -command \
            [list IrcDo $n "/nick $nick"];
 }
}


proc irc_get_chan_key {chan} {
  global irc;
  set chan_cmp [string tolower [list $chan]];
  set pos [lsearch -regexp [string tolower $irc(chanlist)] \
	   "^[quoteall $chan_cmp]( .*)\$"];
  if {$pos==-1} return "";
  lindex [lindex $irc(chanlist) $pos] 1;
}

# cool hack (imo) - by dl
proc quoteall {str} {return "\\[join [split $str ""] \\]"}

proc irc_add_chan {n chanl more} {
 global conn irc; # smart (in)sensistivity for channels
foreach chan [split $chanl ","] {
 set list_cmp [string tolower $irc(chanlist)];
 set new_elem [list $chan];
 set chan_cmp [string tolower $new_elem];
 if {![cequal $more ""]} {
   set new_elem [list $chan $more];
 }
 set pos [lsearch -regexp $list_cmp "^[quoteall $chan_cmp]( .*)?\$"];
 if {$pos!=-1} {
  if {![cequal $new_elem [lindex $irc(chanlist) $pos]]} {
    set irc(chanlist) [lreplace $irc(chanlist) $pos $pos $new_elem];
    IrcBuildChanMenus ;
  }
 } else {
   lappend irc(chanlist) $new_elem;
   IrcBuildChanMenus ;
#   $conn($n,frame).status.chan.m add command -label [join $new_elem] \
#         -command "irc_join $n $new_elem";
#   puts "C$n added channel menu entry";
 }
}
}

proc IrcMenu {n what} {
  irc_fshow $n "+++ Menu: [ircquote $what]" system;
  IrcDoN $n $what;
}

proc irc_toggle_popup {w x y} {
 global $w;
 if {[set $w]} {
   set $w 0;
   $w unpost;
 } else {
   set $w 1;
   $w post $x $y;
   update;
 }
}

#################################
#   Irc Connect                 #
#################################
proc IrcConnect {{host ""} {port ""} {nick ""} {autoexec ""}} {
  global irc conn dcc netmod release;
  if [cequal "" $host] {set host $irc(host)}
  if [cequal "" $port] {set port $irc(port)}
  set n [Connect $host $port "" IrcParse IrcDoN "IRC"];
  if {$n!=-1} {
    set irc($n,nfm) "";
    if {[cequal "" $nick]} {
      set irc($n,nick) $irc(nick); irc_nickhl $n;
    } else {
      set irc($n,nick) $nick; irc_nickhl $n;
    }

    set conn($n,lastlog) $irc(lastlog);

    set irc($n,host) $host;
    set irc($n,port) $port;
    set irc($n,confirmed) 0;
    set irc($n,connected) 0;
    set irc($n,purge) 0;

    set irc($n,lastrec) "";
    set irc($n,lastrecm) "";
    set irc($n,lastrecn) "";
    set irc($n,lastreca) "";

    set irc($n,server) "";

    lappend irc(connections) $n;

    set irc($n,autonick) 0;

    set irc($n,login) 1; # login in progress (first time we get motd,...)

    set irc($n,autoexec) $autoexec;
    set irc($n,curchan) "*";
    set irc($n,nickquery) 0;
    set irc($n,autojoin) "";
    set irc($n,autojoinkey) "";
    set irc($n,curkey) "";
    set irc($n,dotnick) "";
    set irc($n,comanick) "";
    set irc($n,quit) 0;
    set irc($n,away) 0;
    set irc($n,autoaway) 0;
    set irc($n,autoawaytime) $irc(auto_away_time); # counter
    set irc($n,lastmsg) [clock seconds];
    set irc($n,last_sts) [clock seconds];
    set irc($n,logfilename) $irc(logfile);
    set irc($n,log) $irc(log);
    set irc($n,statusaway) ""
    set dcc($n,who) "unknown";
    set dcc($n,file) "none";

    if {$netmod} {
      irc_fshow $n "Shift-Connect: auto exec disabled !" system;
      set irc($n,doautoexec) 0;
    } else {
      set irc($n,doautoexec) 1;
    }