irc.pli

net plug source code

    irc_regTags $n;

    set irc($n,timer) [after 30000 "irc_timer $n 30000"];
 
    set w $conn($n,frame);
    frame $w.status ;

    menubutton $w.status.nick -textvariable irc($n,nick) -pady 0 \
               -menu $w.status.nick.m ;
    button $w.status.away  -textvariable irc($n,statusaway) -pady 0 \
             -relief flat -command "IrcDo $n /away";
    label $w.status.time  -textvariable irc(time) -pady 0;
    irc_time;

    menubutton $w.status.dest -text "dest:" -pady 0 -menu $w.status.dest.m;

    menubutton $w.status.chan -textvariable irc($n,curchan) -pady 0 \
               -menu $w.status.chan.m ;

    menubutton $w.status.mb -indicatoron 1\
               -menu $w.status.mb.m -pady 0

    IrcBuildMenus $n;

    pack $w.status.mb $w.status.time -side right -pady 0 -ipady 0;

    pack $w.status.nick $w.status.away $w.status.dest $w.status.chan -padx 0 \
      -side left -pady 0 -ipady 0;

    set irc($n,user_status) [subst $irc(user_status)];

    label $w.status.logmsgn -textvariable irc($n,logmsgn) -pady 0\
        -padx 0 -foreground red  ;
    pack $w.status.logmsgn -padx 5m -pady 0 -side left;

    label $w.status.us -textvariable irc($n,user_status) -pady 0\
        -relief groove ;
    pack $w.status.us -pady 0;
    bind $w.status.us <Control-1> "destroy $w.status.us";
        

    set irc($n,status) $irc(status) ;
    pack $w.status -after $conn($n,entry) -fill x \
      -pady 0 -ipady 0 -side $irc($n,status) ;

    bind $w.status <Control-1> "destroy $w.status";
    bind $w.status <1> "irc_change_status $n";
   
    set we $conn($n,entry);
    bind $we <Control-g> "$we insert insert \a";
    bind $we <Tab> "irc_tabnext $we conn($n,what)";
    bind $we <Shift-Tab> "irc_tabprevious $we conn($n,what)";
    bind $we <Control-r> "irc_tabprevious $we conn($n,what)";
    bind $we <Alt-a> "$we insert insert \x01";
    bind $we <Alt-v> "$we insert insert \x16";
    bind $we <Alt-b> "$we insert insert \x02";
    bind $we <Alt-c> "$we insert insert \x03";
    bind $we <Alt-u> "$we insert insert \x1f";
    bind $we <Alt-underscore> "$we insert insert \x1f";
    bind $we <Alt-space> "tkMbPost $w.status.chan %X %Y";
    bind $we <Alt-d> "tkMbPost $w.status.dest %X %Y";

    global $w.popupm;
    set $w.popupm 0;
    bind .c$n <3> "irc_toggle_popup $w.popupm %X %Y"
    bind $conn($n,txt) <1> "+$w.popupm unpost"
    bind $w.popupm <Unmap> "set $w.popupm 0; catch {focus $we}";
    bind $we <Alt-m> "irc_toggle_popup $w.popupm %X %Y"
    bind $w.popupm <Alt-m> "$w.popupm unpost"

    bind $we <Control-C> "irc_purge $n";
    bind $conn($n,txt) <Control-C> "irc_purge $n";

    bind $conn($n,txt) <Configure> "irc_regTags $n"

    if {[catch {IU_Bind $n} res]} {
      irc_fshow $n "+++ Error in IU_Bind: $res" error
    }

    # real work on socket
    if {![cequal "" $irc(pass)]} {
      irc_send $n "PASS $irc(pass)";
    }
    irc_send $n "USER $irc(logname) [info hostname] $host :$irc(name)";
    irc_send $n "NICK $irc($n,nick)";
    
    if {[irc_set_my_ip $n]} {return -1}

    set irc(host) $host;
    set irc(port) $port;
  }
  return $n;
}

proc irc_set_my_ip {n} {
    global irc conn;
    if {[catch {set irc($n,myip) [dot2n [lindex [fconfigure $conn($n,sock)\
          -sockname] 0]]} msg]} {
      irc_fshow $n "+++ fconfigure error... can't get my ip... ($msg)" error;
      puts stderr "fconfigure error, can't get my ip... ($msg)";
      return 1;
    } else {
      irc_fshow $n "Detected my ip (32bits DCC suitable form) to be $irc($n,myip)" syst;
    }
    return 0;
}


proc irc_change_status {n} {
  global irc;
  if {[cequal $irc($n,status) "bottom"]} {
    pack .c$n.status -side [set irc(status) [set irc($n,status) "top"]];
  } else {
    pack .c$n.status -side [set irc(status) [set irc($n,status) "bottom"]];
  }
}

proc irc_nickhl {n} {
  global irc
  set str [string tolower $irc($n,nick)];
  regsub -all {[^a-z]} $str {} str;
  if {[cequal "" $str]} {
   set irc($n,nickhl) "!!!!!!!!!"
  } {
   set irc($n,nickhl) $str
  }
}

################# default variables values (color attributes,... ############
#################         customize in your ircrc file           ############
catch {unset irc(user_status)}

#INITVARS
array set irc {
  close_win_on_quit 1

  localchans {&local,&hash,&servers,&numerics,&channel,&kills,&notices,&errors}

  ignore_on_stdout 1
  ignore {}
  status  top
  beep_when_away 1
  auto_away 1
  auto_away_time 5
  remove_away 1
  away_notice 1
  beep 1

  reconnect 0

  auto_nick   1
  
  menu_cancel 1

  shell /bin/csh
  exec {exec $irc(shell) -c "$p"}

  kickmsg "Go away !"
  awaymsg "I can't answer right now... please wait... (set at [irc_time])"

  away_is_auto_away 1

  finger ""
  highlight {(netplug)|($irc($n,nickhl))}
 
  keep_dupl 0
  show_once 1

  server_ping 90

  fastmode 0

  autoexec ""
  autoload ""

  user_status "NetPlug's Irc - v $release"

  logfile {$dotdir/irc.log}
  log     none
  autolog private

  morevars ""
  lastlog  300

  serverlist {}
  srvindex 0

  nicklist {}
  chanlist {#NetPlug}
  destlist {Names Who Topic Mode "Mode b" Ping Part Cycle}

  attrib,normal ""
  attrib,defcmd ""
  attrib,send   ""
  attrib,error  "-foreground red"
  attrib,system "-foreground green4"
  attrib,exec   "-background burlywood"
  attrib,unknown "-foreground sienna4"
  attrib,server  "-foreground blue3"
  attrib,server_notice  "-foreground blue4 -wrap none"
  attrib,channel ""
  attrib,notice ""
  attrib,private "-spacing1 2 -spacing3 2 -background pink"
  attrib,info    "-foreground #a000a0"
  attrib,highlight "-background yellow"
  attrib,all \
    "-lmargin2 24p -tabs {[expr [winfo width $conn($n,txt)]-10] right}"

  msgmem,current 0
  msgmem,length 1
  msgmem,list   "dl"
  msgmem,inclchans 1

  menulist {
    {command -label "brb!" -command [list IrcMenu $n "brb\n/away brb..."]}
    {command -label "back" -command [list IrcMenu $n "/away\nre..."]}
    separator
    {checkbutton -label "Audible Beeps" -variable irc(beep)}
    {checkbutton -label "Auto Nick" -variable irc(auto_nick)}
    {checkbutton -label "Auto Away" -variable irc(auto_away)}
    {checkbutton -label "Man.away like Auto away"\
                         -variable irc(away_is_auto_away)}
    {checkbutton -label "Remove Away when /msg" -variable irc(remove_away)}
    {checkbutton -label "Beep when Away" -variable irc(beep_when_away)}
    {checkbutton -label "Away Notices" -variable irc(away_notice)}
    separator
    {command -label "DCC Accept Chat" -command "IrcMenu $n /accept"}
    {command -label "DCC Accept File" -command "IrcMenu $n /get"}
    separator
    {command -label "Log incoming MSGs" -command \
       [list IrcMenu $n "/setlog private"]}
    {command -label "Log Channel & MSG" -command \
       [list IrcMenu $n "/setlog (channel)|(private)|(send)"]}
    {command -label "No Log" -command \
       [list IrcMenu $n "/setlog none\n/closelog"]}
    {command -label "AutoLog MSG" -command \
       [list IrcMenu $n "/set autolog private"]}
    {command -label "Show Log file content" -command \
       [list IrcMenu $n "/showlog"]}
    {command -label "No AutoLog" -command \
       [list IrcMenu $n "/set autolog none"]}
    {command -label "Reset (erase) LogFile" -command \
       [list IrcMenu $n "/resetlog"]}
    separator
    {command -label "ReLoad ircrc" -command  "IrcMenu $n /load"}
    {command -label "Update Tags" -command "irc_regTags $n"}
    {command -label "Update Menus" -command "IrcBuildMenus $n"}
    separator
    {command -label "Quit" -command "IrcMenu $n /quit"}
  }    
}

################ end of default irc array config values ###############


proc irc_load {{fname ""}} {
  if {[cequal "" $fname]} {
    global dotdir irc;
    set fname "$dotdir/ircrc";
    uplevel #0 [list source $fname];
    set res {};
    lappend res $fname;
    foreach fname $irc(autoload) {
      set fname [subst $fname];
      lappend res $fname;
      uplevel #0 [list source $fname];
    }
    IrcBuildChanMenus;
    return $res;
  } else {
    uplevel #0 "source $fname"
    return $fname;
  }
}

proc irc_save {{fname ""}} {
  global ircAlias irc;
  if {[cequal "" $fname]} {global dotdir;set fname "$dotdir/ircrc"}
  catch {file rename -force $fname $fname.bak}
  set f [open $fname w];
  puts $f "array set ircAlias {";
  catch {unset ircAlias(ACCEPT)}
  catch {unset ircAlias(GET)}
  foreach a [lsort [array names ircAlias]] {
    puts $f "  [list $a $ircAlias($a)]";
  }
  puts $f "}";
  puts $f "set irc(menulist) {";
  foreach m $irc(menulist) {
    puts $f "  [list $m]";
  }
  puts $f "}";
  #SAVEDVARS
  foreach v {first nick name logname host port fontbold close_win_on_quit
             serverlist nicklist chanlist destlist
             beep_when_away auto_away auto_away_time away_notice
             beep kickmsg status highlight fastmode
             autoexec autoload msgmem,inclchans msgmem,length msgmem,list
             morevars user_status logfile log autolog shell exec reconnect
             auto_nick remove_away awaymsg lastlog away_is_auto_away finger
             keep_dupl show_once server_ping pass menu_cancel ignore_on_stdout
	     ignore localchans
  } {
    puts $f "set irc($v) [list $irc($v)]";
  }
  foreach v [lsort [array names irc "attrib,*"]] {
    puts $f "set irc($v) [list $irc($v)]";
  }
  foreach p [lsort [info procs "IU_*"]] {
    puts $f "[list proc $p [info args $p] [info body $p]]";
  }
  foreach v $irc(morevars) {
    puts $f "set irc($v) [list $irc($v)]";
  }
  close $f;
  puts "save in $fname";
  return $fname;
}


# tab keys management
proc irc_tabadd {n nick} {
  global irc;
  set nick_cmp [string tolower $nick];
  set list_cmp [string tolower $irc(msgmem,list)];
  set p [lsearch -exact $list_cmp $nick_cmp];
  set irc(msgmem,current) 0;
  if {$p==$irc(msgmem,length)} return;
  if {$p!=-1} {
    set irc(msgmem,list) [lreplace $irc(msgmem,list) $p $p];
  } else {
    incr irc(msgmem,length);
  }
  lappend irc(msgmem,list) $nick;
}

proc irc_tabdo {we varname n1 n2} {
  global irc;
  upvar 2 $varname var;
  set irc(msgmem,current) [expr \
	  ($irc(msgmem,current)+($n1))%$irc(msgmem,length)];
  set var "/msg [lindex $irc(msgmem,list) \
	  [expr $irc(msgmem,length)-1-$irc(msgmem,current)]] ";
  set irc(msgmem,current) [expr \
	  ($irc(msgmem,current)+($n2))%$irc(msgmem,length)];
  $we icursor end;
  after idle "focus $we";
}

proc irc_tabnext {we varname} {
  irc_tabdo $we $varname 0 1;
}

proc irc_tabprevious {we varname} {
  global irc;
  irc_tabdo $we $varname $irc(msgmem,length)-1 0;
}

############# Start of User commands handling code ##################

# default aliases
array set ircAlias {
  W {[if {$np==0} {return "/WHO $C"} else {return "WHOIS $p $p"}]}
  J JOIN
  C CTCP
  M MSG
  P PING
  H HELP
  ? HELP
  A ALIAS
  LEAVE PART
  L     PART
  IJ    AUTOJOIN
  JL    {quote JOIN $irc(localchans)}
  PL    {quote PART $irc(localchans)}
  UMODE {/MODE $N $p}
  CHAT  "DCC CHAT"
  CD "TCL cd"
  PWD "TCL pwd"
  CVERS {[if {$np==0} {set p $C}; return "CTCP $p VERSION"]}
  CSRVSTART {TCL dcc_chat_server $n 1}
  CSRVSTOP  {TCL dcc_chat_server $n 0}
  FSRVSTART {TCL dcc_file_server $n 1}
  FSRVSTOP  {TCL dcc_file_server $n 0}
  SET {TCL set irc($0) $1p}
  ON  {TCL set ircOn($0) $1p}
  SETLOGFN {TCL set irc($n,logfilename) $p}
  SETLOG {TCL set irc($n,log) $p}
  SETLASTLOG {TCL set conn($n,lastlog) $p}
  MODE {[if {$np==0} {return "/MODE $C"}\
     elseif {![string match {[&#]*} $0]} {return "/MODE $C $p"} \
     else {return "/MODE $p"}]}
  TOPIC {[if {$np==0} {return "/TOPIC $C"}\
     elseif {![string match {[&#]*} $0]} {return "/TOPIC $C :$p"} \
     else {return "/TOPIC $0 :$1p"}]}
  SHOWLOG {Tcl FileOpen $irc($n,logfilename) r}
  COUNTLOG {Tcl [list set irc($n,logmsgn)\
   [string trimleft [exec /bin/csh -c "wc -l < [subst $irc($n,logfilename)]"]\
           " 0"]]}
  KPATH {Tcl set irc($n,kpath)}
  DATE TIME
  EXIT QUIT
  I INVITE
  Q QUERY
  CONN CONNECT
  NOIGNORE {set ignore {}}
  IGNORE {[if {$np} {return "Tcl lappend irc(ignore) $p"}\
               else {return "set ignore"}]}
}

array set ircCmd {
  PURGE {irc_purge $n; return}
  SAVE {
    if {[catch "irc_save $p" res]} {
      irc_fshow $n "+++ save error : $res" system;
    } else {
      irc_fshow $n "+++ successfully saved $res" system;
    }
    return;
  }
  LOAD {
    if {[catch "irc_load $p" res]} {
      irc_fshow $n "+++ load error : $res" system;
    } else {
      irc_fshow $n "+++ successfully loaded $res" system;
    }
    return;
  }
  EXEC {# could be /alias exec tcl exec more or less...
    if {$np==0} {irc_syntaxerror$n "/exec <shell command>"; return}
    if {[catch {set exec [subst $irc(exec)]; eval $exec} res]} {
      irc_fshow $n "+++ Error executing \"$p\" : $res" \
        error;
    } else {
      irc_fshow $n $res exec;
      irc_fshow $n "+++ End of Exec \"$p\"" system;
    }
    return;
  }
  EXECO {
    if {$np==0} {irc_syntaxerror$n "/execo <shell command>"; return}
    if {[catch {set exec [subst $irc(exec)]; eval $exec} res]} {
      irc_fshow $n "+++ Error executing \"$p\" : $res" \
        error;
    } else {
      foreach line [split $res \n] {
	defOut $n 0 ">" exec; defOut $n 0 " ";
	irc_fshow $n $line send;
	irc_send $n "PRIVMSG $irc($n,curchan) :$line";
      }  
    }
    return;
  }
  TCL {
    uplevel #0 "set n $n";