irc.pli

net plug source code

    if {[catch {uplevel #0 $p} res]} {
      irc_fshow $n "+++ Error evaluating \"$p\" : $res" \
        error;
    } else {
      irc_fshow $n "+++ Tcl \"$p\" : $res" \
        system;
    }
    return;
  }
  CLEAR {
      set w $conn($n,txt);
      $w configure -state normal;
      $w delete 1.0 end;
      $w configure -state disabled;
      return;
  }
  CONFIG {IrcConfigEdit; return}
  HELP {
    irc_fshow $n "+++ Available commands : [lsort [array names ircCmd]]" \
      system; 
    return;
  }
  UNALIAS {
    foreach elem $p {
      set elem [string toupper $0];
      unset ircAlias($elem);
    }
    irc_fshow $n "+++ Removed Alias(es) : $p" system;
    return;
  }
  QUOTE {
    irc_fshow $n $p defcmd;
    irc_send $n $p;
    return;
  }
  ALIAS {
    if {$np>1} {
      set a [string toupper $0];
      set ircAlias($a) $1p;
      irc_fshow $n "+++ New Alias $a -> [list $1p]" system;
    } elseif {$np} {
      set a [string toupper $0];
      catch {set ircAlias($a)} v;
      irc_fshow $n "+++ ALIAS $a [list $v]" system;
    } else {
      set res {}
      foreach a [lsort [array names ircAlias]] {
	lappend res "+++ ALIAS $a [list $ircAlias($a)]";
      }
      irc_fshow $n [join $res \n] system;
    }
    return;
  }
  DCC {
    if {$np>1} {
      global dcc;
      set what [string toupper $0];
      switch -exact $what {
	SEND {
	  if {$np!=3} {
	      irc_syntaxerror $n "/dcc SEND <nick> <filename>";
	      return;
	  }
          set who $1;
	  set filename $2;
	  if {[catch {file size $filename} sz]} {
	    irc_fshow $n "+++ Can't send \"$filename\" : $sz" error;
	    return;
	  }
	  set dcc($n,file) $filename;
	  set port [dcc_file_server $n 1];
	  irc_send $n "PRIVMSG $who :\01DCC SEND [file tail $filename]\
                       $irc($n,myip) $port $sz\01";
	  irc_fshow $n "-> $who : DCC $what $filename ($sz bytes)\
                          (listen on port $port)";
        }
	CHAT {
          set who $1;
	  set dcc($n,who) $who;
	  set port [dcc_chat_server $n 1];
          irc_send $n "PRIVMSG $who :\01DCC CHAT chat\
                       $irc($n,myip) $port\01";
	  irc_fshow $n "-> $who : DCC $what (listen on port $port)";
	}
	GET {
	  if {$np!=5} {
	      irc_syntaxerror $n "/dcc GET <filename> <host> <port> <size>";
	      return;
	  }
	  set filename $1;
          if {[file exists $filename]} {
            irc_fshow $n "[irc_time] DCC GET $filename exists using\
                          ${filename}~ instead" system;
            append filename "~"
          }
	  set host $2;
          set port $3;
          set size $4;
	  dcc_receive $n $filename $host $port $size;
	}
	CONNECT {
	  if {$np!=4} {
	      irc_syntaxerror $n "/dcc CONNECT <who> <host> <port>";
	      return;
	  }
          set who  $1;
	  set host $2;
          set port $3;
	  irc_fshow $n "[irc_time] DCC CONNECT host $host, port $port (for\
             $who)";
	  dcc_connect $who $host $port;
	}
	default {
	  irc_fshow $n "+++ syntax error: /dcc type must be CHAT,\
             CONNECT, GET or SEND" error;
	}
      }
    } else {
      irc_syntaxerror $n "/dcc <type> <dest> <args...>";
    }
    return;
  }
  QUERY {
    if {$np!=1} {
      irc_syntaxerror $n "/query <destination>";
      return;
    }
    irc_fshow $n "+++ default destination is now $0" system;
    set irc($n,curchan) $0;
    set irc($n,nickquery) [regexp {^[^&+#]} $0];
    return;
  }
  AUTOJOIN {
    if {[cequal "" $irc($n,autojoin)]} {
      irc_fshow $n "+++ Can't auto join, no autojoin channel set" error;
    } else {
      irc_add_chan $n $irc($n,autojoin) $irc($n,autojoinkey);
      irc_join $n $irc($n,autojoin) $irc($n,autojoinkey);
    }
    return;
  }
  JOIN {
    if {$np==0} {
      irc_syntaxerror $n "/join <channel> <opt args...>";
      return;
    }
    set chan $0;
    irc_add_chan $n $chan $1p;
    irc_join $n $chan $1p ;
    return;
  }
  CYCLE {
    if {$np==0} {
      set chan $C
      set key  $irc($n,curkey);
    } elseif {$np==1} {
      set chan $0
      set key  [irc_get_chan_key $chan];
    } else {
      set chan $0
      set key $1p;
    }
    irc_send $n "PART $chan :cycling";
    irc_send $n "JOIN $chan $key";
    return;
  }
  INVITE {
    if {$np==0} {
      irc_syntaxerror $n "/invite <nick>" "/invite <nick> <channel>";
      return;
    } elseif {$np==1} {
      set p "$0 $C"
    }
  }
  OPER {
    if {$np==0} {
      irc_syntaxerror $n "/oper <passwd>" "/oper <nick> <passwd>"
    } elseif {$np==1} {
      irc_send $n "OPER $N $0";
    } else {
      irc_send $n "OPER $p";
    }
    return;
  }
  KICK {
    if {$np==1} {
      set p "$C $0 :$irc(kickmsg)";
    } elseif {$np>2} {
      set p "$0 $1 :$2p";
    } else {
      irc_syntaxerror $n "/kick <who>" "/kick <channel> <who> <why...>";
      return;
    }
  }
  CTCP {
    if {$np>1} {
      set who $0;
      set what [join [concat [list [string toupper $1]] [lrange $plst 2 end]]];
      irc_send $n "PRIVMSG $who :\001$what\001";
      irc_show $n "-> $who : CTCP $what" send
    } else {
      irc_syntaxerror $n "/ctcp <dest> <type><args...>";
    }
    return;
  }
  MSG {
    if {$np>1} {
      set who $0;
      switch -exact -- $who {
	"." {
	  set who $irc($n,dotnick);
	}
	"," {
	  set who $irc($n,comanick);
	}
      }
      irc_send $n "PRIVMSG  $who :$1p";
      rem_away $n;
      if {[regexp {^[&+#]} $who]} {
	irc_show $n ">$who> $1p" send;
	if {$irc(msgmem,inclchans)} {irc_tabadd $n $who}
      } else {
	irc_show $n "-> *$who* $1p" send;
	set irc($n,dotnick) $who;
	irc_tabadd $n $who;
        if {$irc(remove_away) && $irc($n,away)} {irc_send $n "AWAY"}
      }
    } else {
      irc_syntaxerror $n "/msg <dest> <what...>" ;
    }
    return
  }
  SAY {
    if {$irc($n,nickquery)} {
      irc_show $n "-> *$C* $p" send
    } else {
      irc_show $n "> $p" send
    }
    irc_send $n "PRIVMSG $C :$p";
    rem_away $n;
    return;
  }
  NOTICE {
    if {$np>1} {
      irc_send $n "NOTICE  $0 :$1p";
      if {[regexp {^[&+#]} $0]} {
        irc_show $n "-$0> $1p" send;
      } else {
        irc_show $n "-> -$0- $1p" send;
      }
    } else {
      irc_syntaxerror $n "/notice <dest> <what...>";
    }
    return
  }
  PING {
    if {$np==0} {set p $C}
    irc_fshow $n "-> $p : PING request..." send;
    irc_send $n "PRIVMSG $p :\001PING [format %u [clock clicks]]\001";
    return;
  }
  ME {
    irc_send $n "PRIVMSG $C :\001ACTION $p\001";
    irc_show $n "* $N $p" send;
    return;
  }
  PART {
    if {$np>0} {
      if {$np>1} {
        set p "$0 :$1p";
      }
    } else {
      set p $C
    }
  }
  QUIT {
    if {$np==0} {
      set p ":I use NetPlug's Irc"
    } else {
      set p ":$p";
    }
    set irc($n,quit) 1;
  }
  AWAY {
    set irc($n,autoaway) 0;
    if {$np==0} {
      set irc($n,away) 0;
    } else {
      if $irc(away_is_auto_away) {
        set irc($n,autoaway) 1;
      }
      set irc($n,away) 1;
      irc_show $n "AWAY :$p" defcmd;
      irc_away $n $p;
      return;
    }
  }
  WHO   {if {$np==0} {set p $C}}
  NAMES {if {$np==0} {set p $C}}
  LIST  {if {$np==0} {set p $C}}
  SERVER {
   if {$np>0} {
     set srv $0;
     if {$np<2} {
       set port $irc(port);
     } else {
       set port $1;
     }
     set cmd "QUIT"; set p ":Changing Server";
     if {[cequal "" $C]} {
       after 1000 [list IrcConnect $srv $port $N];
     } else {
       after 1000 [list IrcConnect $srv $port $N [list "/join $C"]];
     }
     set irc($n,quit) 1;
     global netmod; set netmod 0;
   } else {
     irc_syntaxerror $n "/server <server> <optional port>";
     return;
   }
  }
  CLOSELOG {
    if {[info exist irc($n,logfile)]} {
      close $irc($n,logfile);
      unset irc($n,logfile);
      defOut $n 0 "+++ Log file closed ([subst $irc($n,logfilename)])\n"\
	system;
    }
    set irc($n,logmsgn) "";
    return;
  }
  RESETLOG {
    catch {eval $ircCmd(CLOSELOG)};
    set fname [subst $irc($n,logfilename)];
    close [open $fname w];
    irc_fshow $n "+++ Log file $fname reset" system;
    return;
  }
  KILL {
    if {$np<2} {
      irc_syntaxerror $n "/kill <nick> <reason...>"
      return;
    } else {
      set p "$0 :$1p"
    }
  }
  SQUIT {
    if {$np<2} {
      irc_syntaxerror $n "/squit <server> <reason...>"
      return;
    } else {
      set p "$0 :$1p"
    }
  }
}

############# End of User commands handling code ##################


proc irc_syntaxerror {n err1 {err2 ""}} {
  defOut $n 0 "+++ syntax error: use \"" error;
  defOut $n 0 $err1 system;
  if {![cequal $err2 ""]} {
    defOut $n 0 "\" or \"" error;
    defOut $n 0 $err2 system;
  }
  defOut $n 0 "\" instead\n" error;
  update;
}

proc irc_idle {n} {
  global irc
  expr int(([clock seconds]-$irc($n,lastmsg))/60);
}
# format current time
proc irc_time {} {
  global irc;
  set irc(time) [clock format [clock seconds] -format "%H:%M"];
  return "\[$irc(time)\]";
}

#proc IrcUserInput {n str} {IrcDoN $n $str}

proc rem_away {n} {
 global irc
 if {$irc($n,autoaway)} {
   irc_send $n "AWAY"
   irc_fshow $n "[irc_time] (auto) away removed (after [irc_idle $n] mins\
                   idle)" system;
   set irc($n,autoaway) 0;
   set irc($n,away) 0;
   set irc($n,autoawaytime) $irc(auto_away_time);
 }
 set irc($n,lastmsg) [clock seconds];
 set irc($n,lastrecm) "";
}

proc IrcDoN {n inputstr} {
  foreach str [split $inputstr \n] {
      if {[cequal $str ""]} continue;
      IrcDo $n $str
  }
}

proc IrcDo {n str} {
 global irc conn ircCmd ircAlias dotdir release;
 set N $irc($n,nick);
 set C $irc($n,curchan);
 if {[string match "/*" $str]} {
   set str [string range $str 1 end];
   # alias substitution
   set break 0;
   while 1 {
     if {![regexp {^([^ ]+)( +(.*))?$} $str all cmd r p]} {
        puts stderr "parse error in IrcDo for '$str' !"; return;
     }
     set np 0;
     set plst [split $p];
     foreach word $plst {set $np $word;incr np}
# puts "#=($np), plst=($plst), p=($p)";
     set cmd [string toupper $cmd];
     # often used
     set 1p [join [lrange $plst 1 end]];
     set 2p [join [lrange $plst 2 end]];
     if {[string match "/*" $cmd]} {set cmd [string range $cmd 1 end]; break;}
     if {!$break && ([info exists ircAlias($cmd)])} {
       set subst $ircAlias($cmd);
# puts "alias substitution for $cmd ($p) : '$subst'";
       set pstr $str;
       if [catch {set str [subst $subst]} res] {
	 irc_fshow $n "+++ Error in alias substitution for $cmd ($subst) :\
	    $res" error;
	 return;
       }
# puts "alias substitution result : '$str'";
       if {[cequal $str $subst]} {
         # if subst did nothing (simple aliases), we add params if needed:
	 if {![cequal "" $p]} {
	   set str "$str $p";
         }
       }
       if {[cequal $str $pstr]} {
         # exactly the same string is produced, prevent loops and break:
         break;
       }
       if {[string match "/*" $str]} {
         # returned string starts with a /, the alias want the command to
         # be called directly:
         set str [string range $str 1 end];
         set break 1; # but we need to build new $p, $0,... delay the break
       }
     } else {
       break;
     }
   }
# puts "#=($np), cmd=($cmd), p=($p)";