irc.pli

net plug source code

   if {[info exists ircCmd($cmd)]} {
      switch [catch {eval $ircCmd($cmd)} res] {
        0 {}
        2 {return}
        default {
         irc_fshow $n "+++ Error in command evaluation for $cmd : $res " error;
         return;
	 }
      }
   }
   # if no "return" was issued...
# puts "cmd=($cmd), p=($p)";
   if {[cequal "" $p]} {set tosend $cmd} {set tosend "$cmd $p"} 
   irc_fshow $n $tosend defcmd;
   irc_send  $n $tosend;
 } else {
   set p $str;
   eval $ircCmd(SAY)
 }
}

proc irc_reconnect_str {n {nxtsrv 0}} {
  global irc;
  if {$nxtsrv && [llength $irc(serverlist)]} {
    while 1 {
      set srvport [lindex $irc(serverlist) $irc(srvindex)];
      incr irc(srvindex);
      if {[cequal "" $srvport]} {
        defOut $n 0 \
          "\n### All auto servers exhausted... restarting from top..." system;
        set irc(srvindex) 0;
        continue;
      }
      set host [lindex $srvport 0];
      set port [lindex $srvport 1];
      defOut $n 0 "\n### Auto server next try with $host $port" system;
      break;
    }
  } else {
    set host $irc($n,host);
    set port $irc($n,port);
  }
  if {$irc($n,nickquery) || ([cequal "*" $irc($n,curchan)])} {
    list IrcConnect $host $port $irc($n,nick) ;
  } else {
    if {[cequal "" $irc($n,curkey)]} {
      list IrcConnect $host $port $irc($n,nick)\
           [list "/join $irc($n,curchan)"];
    } else {
      list IrcConnect $host $port $irc($n,nick)\
           [list "/join $irc($n,curchan) $irc($n,curkey)"];
    }
  }
}

proc IrcParse {n errflag str} {
  global clicks irc conn;
  set clicks [format %u [clock clicks]];
  set irc($n,last_sts) [clock seconds];
  upvar #0 irc($n,nfm) nfm;
  if {$errflag} {
#puts "ERR on $n ($errflag $str)";
    after cancel $irc($n,timer);
    if {(![cequal "" $nfm]) && ($errflag!=2)} {irc_parse $n $nfm}
    set efl2 [expr 2*($errflag==2)]; # 2 if erfflag is 2 , 0 otherwise
    catch {dcc_chat_server $n 0 $efl2}
    catch {dcc_file_server $n 0 $efl2}
    set pos [lsearch $irc(connections) $n];
    set irc(connections) [lreplace $irc(connections) $pos $pos];
    if {$errflag!=2} {# window is not already destroyed
      defOut $n $errflag $str;
      if {$irc($n,quit) && $irc(close_win_on_quit)} {
        catch {destroy .c$n};
      } else {
        if {!$irc($n,quit)} {
          global ircOn;
          eval $ircOn(CLOSED)
        }
        catch {destroy .c$n.e}
        catch {destroy .c$n.status.nick .c$n.status.away \
               .c$n.status.dest .c$n.status.time \
	       .c$n.status.chan}
        catch {set wm .c$n.status.mb.m; destroy $wm; menu $wm -tearoff 0;
           set cmd [irc_reconnect_str $n];
	   if {$irc(menu_cancel)} {
	     set cancel "catch {$conn($n,txt).bcancel invoke}";
           } else {
             set cancel "";
           }
           $wm add command -label "Re Connect & Dismiss" -command \
	      "$cancel;destroy .c$n;$cmd";
           $wm add command -label "Just Re Connect" -command "$cancel;$cmd";
	   $wm add separator;
           $wm add command -label "Just Dismiss Window" -command "$cancel;destroy .c$n"
           pack .c$n.status.mb -side left
	   bind .c$n.status <1> "";
        }
        wm deiconify .c$n;
      }
    }
    foreach el [array names irc $n,*] {unset irc($el)}
    foreach el [array names dcc $n,*] {unset dcc($el)}
    if {$errflag!=2} update;
    return;
  }
#  puts "irc parsing '$str'...";
#  regsub -all "\r" $str {} str;  # with auto translate, no \r shall occur
  set doitnow $nfm;
  set lastlf [string last "\n" $str]
  if {$lastlf==-1} {
    append nfm $str
  } else {
    set nfm [string range $str [expr $lastlf+1] end]
    append doitnow [string range $str 0 [expr $lastlf-1]]
    foreach message [split $doitnow "\n"] {
      if {$irc($n,purge)} {
        puts $message
      } else {
        if {[catch {irc_parse $n $message} res]} {
          global errorInfo;
          set msg "+++ Bug: Tcl exception while parsing '[ircquote $message]':"
          irc_fshow $n "$msg $res" error; update;
          puts stderr $msg;
          puts stderr $errorInfo;
        }
      }
    }
    if {$irc($n,purge)} {
      puts -nonewline $nfm; set nfm "";
      set sock $conn($n,sock);
      set cont 3;
      while {$cont} { # fblocked & stuff does not seem to work...
        set r [catch {read $sock} more]
        puts -nonewline $more;
        if {$r} break;
        if {[cequal $more ""]} {
          incr cont -1;
          update;
          if {$cont} {after 250}
        } else {
          set cont 3;
        }
      }
      puts "###END OF PURGE";
      set irc($n,purge) 0;
    }
  }
#  defOut $n 0 $str;
}

proc irc_purge {n} {
  global irc;
  set msg "### PURGING remaining queued message for C$n to stdout";
  irc_fshow $n $msg error;
  puts $msg;
  set irc($n,purge) 1;
  update idletasks; 
}

proc irc_parse {n buffer} {
  global irc;
if {![regexp {^(:([^ !]*)(!([^ ]*))? +)?([^: ]*)( +([^ :]*)((:| +:?)(.*))?)?$}\
           $buffer all from from2 ff from3 code argm argm1 rest rest1 rest2]} {
     puts stderr "IRC_PARSE NO MATCH!! \[$buffer\]"
     return
  }
  if {$irc(keep_dupl) || (![cequal $buffer $irc($n,lastrec)])} {
    set irc($n,lastrec) $buffer;
    foreach i $irc(ignore) {
      if {[string match $i "$from2!$from3"]} {
	if {$irc(ignore_on_stdout)} {
	  puts "IGNORED $n ($i) : [ircquote $buffer]"
	}
	return;
      }
    }
    irc_handle $n $from2 $from3 [string tolower $code] $argm1 $rest2;
  } else {
    puts "SKIPPED S$n [ircquote $buffer]"
  }
}

if [info exists icb(clicks)] {set irc(clicks) $icb(clicks)}

if ![info exists irc(clicks)] {
# ticks scale
set t [clock clicks]
after 1000
set t [expr [clock clicks]-$t]
set irc(clicks) [format %.2g $t];
debug 1 "Clicks per seconds =$t -> $irc(clicks)";
}

proc irc_send {n what} {
  global irc;
  Send $n "$what\n";
  set irc(msgmem,current) 0;
  set irc($n,lastrec) "";
#puts "IRC: sent on ($n) : $what"; flush stdout;
}

if $GUI {
catch {text .testopt}
if ![info exist irc(font)] {
  set irc(font) [lindex [.testopt configure -font] 4];
}
if ![info exist irc(fontbold)] {
  if {![regsub -nocase "medium" $irc(font) "bold" irc(fontbold)]} {
    set irc(fontbold) "*-bold-*";
  }
}
if ![info exist irc(bgcol)] {
  set irc(bgcol) [lindex [.testopt configure -bg] 4];
}
if ![info exist irc(fgcol)] {
  set irc(fgcol) [lindex [.testopt configure -fg] 4];
}
catch {destroy .testopt}
}

proc irc_regTags {n} {
  global irc conn;
  set w $conn($n,txt);
  puts "Updating Tags for $n";
  foreach tagname [array names irc "attrib,*"] {
    regTag $w [string range $tagname 7 end] [subst $irc($tagname)];
  }
  regTag $w bold "-font \"$irc(fontbold)\"";
  regTag $w underline "-underline 1";
  regTag $w inverse "-background $irc(fgcol) -foreground $irc(bgcol)";

  $w tag lower all;
}

proc irc_fshow {n what {attrib normal}} {
  global irc
  if {([regexp $irc($n,log) $attrib]) \
   || ($irc($n,autoaway) && ([regexp $irc(autolog) $attrib]))} {
     irc_filelog $n $what
  }
  defOut $n 0 $what\n $attrib
}

proc irc_highlight {n what attrib} {
  global irc;
  if ![cequal "" [set hl0 [subst $irc(highlight)]]] {
    set nmatch 0;
    while {[regexp -nocase "(^|\[^a-z\03\])($hl0)(\[^a-z\]|\$)" $what all a1\
	    hl1]} {
      incr nmatch [regsub -all -nocase "(^|\[^a-z\03\])($hl1)(\[^a-z\]|\$)" \
		   $what "\\1\03\\2\03\\3" what]
    }
    if $nmatch {IU_Highlight $n $attrib $nmatch $hl0 $what};
  }
  return $what;
}

proc irc_show {n what {attrib normal} {update 0} {updateidle 1}} {
  global irc;
  if {([regexp $irc($n,log) $attrib]) \
   || ($irc($n,autoaway) && ([regexp $irc(autolog) $attrib]))} {
     irc_filelog $n $what
  }
  set c "\x1f"
  regsub -all "\01" $what "${c} ${c}" what;
  set what [irc_highlight $n $what $attrib];
  if [regsub -all "\a" $what {} what] {
    IU_Beep;
    irc_combine $n "$what" $attrib;
    defOut $n 0 " <bip>\n" system;
  } else {
    irc_combine $n "$what\n" $attrib;
  }
  if $update update elseif $updateidle {update idletasks}
}

proc ircquote {str} {
  regsub -all {\\} $str {\\\\} str ;
  regsub -all "\n" $str {\n} str ;
  regsub -all "\r" $str {\r} str ;
  regsub -all "\t" $str {\t} str ;
  regsub -all "\001" $str {\\001} str ;
  regsub -all "\002" $str {\\002} str ;
  regsub -all "\017" $str {\\017} str ;
  regsub -all "\026" $str {\\026} str ;
  regsub -all "\037" $str {\\037} str ;
  return $str;
}

proc irc_cvrtTS {ts} {
  clock format $ts -format {%a %b %d %Y %H:%M}
}

proc irc_cvrtsec {sec {more ""}} {
  if {![cequal "" $more]} {set more ".$more"}
  if {$sec<60} {return "$sec$more seconds"}
  set min [expr $sec/60];
  set sec [expr $sec%60];
  append sec $more;
  if {$min==1} {return "1 minute and $sec s"}
  if {$min<60} {return "$min minutes and $sec s"}
  set hour [expr $min/60];
  set min  [expr $min%60];
  if {$min<=1} {set min "$min min"} else {set min "$min mins"}
  if {$hour==1} {return "1 hour, $min and $sec s"}
  if {$hour<24} {return "$hour hours, $min and $sec s"}
  set day [expr $hour/24];
  set hour [expr $hour%24];
  if {$hour<=1} {set hour "$hour hour"} else {set hour "$hour hours"};
  if {$day==1} {return "1 day, $hour, $min and $sec s"}
  return "$day days, $hour, $min and $sec$more s"
}

proc irc_away {n msg} {
  global irc;
  irc_send $n "AWAY :$msg"
  set irc($n,awaymsg) $msg;
}

proc irc_aas {idle} {
  global irc;
  set more "";
  if {[string match "*private*" $irc(autolog)]} {
    set more " - messages logged"
  }
  return "\[Auto away on idle (>$idle mins)$more\]";
}

proc irc_timer {n time} {
  global irc;
  irc_time;
#puts "periodic timer $n  Before Update";
  update;
#puts "periodic timer $n  After  Update";
  if {![info exists irc($n,lastmsg)]} return; # we were deleted at update
  set idle [irc_idle $n];
#puts "periodic timer $n  Ok, idle=$idle";
  if {($irc(auto_away)) && (!$irc($n,away)) && ($idle>=$irc(auto_away_time))} {
    if {$idle>=$irc($n,autoawaytime)} {
      incr irc($n,autoawaytime) $irc(auto_away_time);
      set irc($n,autoaway) 1;
      irc_away $n [irc_aas $idle];
      irc_fshow $n "[irc_time] auto away set (idle >$idle mins)" system;
    }
  }
  set srvidl [expr [clock seconds]-$irc($n,last_sts)];
  if {$srvidl>=$irc(server_ping)} {
    puts "P$n : [irc_time] server sent nothing for $srvidl secs, pinging it !";
    catch {irc_send $n "PING $irc(nick)"}
  }
  set irc($n,timer) [after $time "irc_timer $n $time"];
}


catch {unset ircCtcp(VERSION)}

proc irc_handle {n from uhost cmd arg rest} {
#puts "IRC: we have a $cmd from=($from) arg=($arg) rest=([ircquote $rest])"
  set arglc [string tolower $arg];
  global irc version release ircOn;
  if $irc($n,connected)==0 {
    set irc($n,connected) 1;
    set irc(srvindex) 0;
  }
  set irc(msgmem,current) 0;
  set N $irc($n,nick);
  set C $irc($n,curchan);
  set nick [string tolower $N];
  set to_me [cequal $arglc $nick];
  set from_me [cequal [string tolower $from] $nick];

  set to_chan [regexp {^[#&+]} $arg];
  set to_curchan [cequal $arglc [string tolower $C]];

#  IU_On $n $to_me $to_chan $to_curchan $from $uhost $cmd $arg $rest;
  if {[info exists ircOn($cmd)]} {
    eval $ircOn($cmd)
  } elseif {[regexp {([0-9])[0-9][0-9]} $cmd all type]} {
    eval $ircOn(NUMERIC);
    if {$type<4} {
      irc_fshow $n "*** $str" server
    } elseif {$type<6} {
      irc_fshow $n "### $str" error
    } else {
      irc_fshow $n "+++ $str" unknown; update;
    }
  } else {
    irc_show $n "+++ $irc($n,lastrec)" unknown 1;
  }
}

############# Start of Incoming (server) message handling code ############
proc ctcp_reply {n who cmd what} {
  irc_send $n "notice $who :\001$cmd$what\001"
}
# ctcps : 
# (utc and time are not doing what they should (according to 'protocol'))
array set ircCtcp {
 PING {ctcp_reply $n $from $ctcpcmd $ctcprest}
 ACTION {
    if {$to_me} {
      irc_show $n "*> $from $ctcpargs" private;
    } elseif {$to_curchan} {
     irc_show $n "* $from $ctcpargs";
    } else {
     irc_show $n "* $from:$arg $ctcpargs";
    }
    return;
  }
 VERSION {
    global release version tcl_platform tcl_patchLevel tk_patchLevel;
    ctcp_reply $n $from $ctcpcmd " NetPlug's Irc by dl: R$release (N$version\
             I$irc(version) Tcl$tcl_patchLevel Tk$tk_patchLevel) : $irc(date),\
	     Last load $irc(load) / $tcl_platform(os) $tcl_platform(machine)";
 }
 TIME {ctcp_reply $n $from $ctcpcmd " [clock format [clock seconds]]"}
 UTC {ctcp_reply $n $from $ctcpcmd " [clock format [clock seconds]\
				     -format "%T %D" -gmt 1]"}
 SOURCE {
  if {[cequal "URL" $ctcpargs]} {
    ctcp_reply $n $from $ctcpcmd " http://www.demailly.com/~dl/netplug.html";
  } else {
    ctcp_reply $n $from $ctcpcmd " ftp.demailly.com:/pub/:NetPlug.tar.gz";
  }
 }
 CLIENTINFO {
   ctcp_reply $n $from $ctcpcmd " [array names ircCtcp]";
 }
 DCC {
   if {[regexp "^(\[^ \]+) (\[^ \]+) (\[0-9\]+) (\[0-9\]+)( (\[0-9\]+))?$"\
	     $ctcpargs all dcc1 dcc2 dcchost dccport ds dccsize]} {
     dcc_query $n $from $dcc1 $dcc2 $dcchost $dccport $dccsize;
   }
 }
 FINGER {ctcp_reply $n $from $ctcpcmd " $N ($irc(finger)), Idle [irc_cvrtsec [expr\
				       [clock seconds]-$irc($n,lastmsg)]]"}
 IDLE {ctcp_reply $n $from $ctcpcmd " [irc_cvrtsec [expr\
                                       [clock seconds]-$irc($n,lastmsg)]]"}
}


array set ircOn {
  ping {
    irc_send $n "PONG $rest";
    set irc($n,lastrec) "";
    return;
  }
  pong {
    if {![cequal $irc($n,server) $from]} {
      irc_fshow $n "[irc_time] PONG from $from : $arg ($rest)" info; update
    }
  }
  MSG           {irc_show $n "*$from!$uhost* $rest" private 1;}
  PUBLIC        {irc_show $n "<$from> $rest" channel 1;}
  PUBLIC_OTHER  {irc_show $n "<$from:$arg> $rest" channel 1;}
  JOIN          {irc_fshow $n "[irc_time] $from ($uhost) joined $rest" info;}