chiark - git - mdw - ircbot/blob - bot.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3 set host chiark
   4 set port 6667
   5 if {![info exists nick]} { set nick Blight }
   6 if {![info exists ownfullname]} { set ownfullname "here to Help" }
   7 set ownmailaddr blight@chiark.greenend.org.uk
   8
   9 if {![info exists globalsecret]} {
  10     set gsfile [open /dev/urandom r]
  11     fconfigure $gsfile -translation binary
  12     set globalsecret [read $gsfile 32]
  13     binary scan $globalsecret H* globalsecret
  14     close $gsfile
  15     unset gsfile
  16 }
  17
  18 proc manyset {list args} {
  19     foreach val $list var $args {
  20         upvar 1 $var my
  21         set my $val
  22     }
  23 }
  24
  25 proc try_except_finally {try except finally} {
  26     global errorInfo errorCode
  27     set er [catch { uplevel 1 $try } emsg]
  28     if {$er} {
  29         set ei $errorInfo
  30         set ec $errorCode
  31         if {[catch { uplevel 1 $except } emsg3]} {
  32             append ei "\nALSO ERROR HANDLING ERROR:\n$emsg3"
  33         }
  34     }
  35     set er2 [catch { uplevel 1 $finally } emsg2]
  36     if {$er} {
  37         if {$er2} {
  38             append ei "\nALSO ERROR CLEANING UP:\n$emsg2"
  39         }
  40         return -code $er -errorinfo $ei -errorcode $ec $emsg
  41     } elseif {$er2} {
  42         return -code $er2 -errorinfo $errorInfo -errorcode $errorCode $emsg2
  43     } else {
  44         return $emsg
  45     }
  46 }
  47
  48 proc sendout {command args} {
  49     global sock
  50     if {[llength $args]} {
  51         set la [lindex $args end]
  52         set args [lreplace $args end end]
  53         foreach i $args {
  54             if {[regexp {[: ]} $i]} {
  55                 error "bad argument in output $i ($command $args)"
  56             }
  57         }
  58         lappend args :$la
  59     }
  60     set args [lreplace $args 0 -1 $command]
  61     set string [join $args { }]
  62     puts "[clock seconds] -> $string"
  63     puts $sock $string
  64 }
  65
  66 proc log {data} {
  67     puts $data
  68 }
  69
  70 proc logerror {data} {
  71     log $data
  72 }
  73
  74 proc saveeic {} {
  75     global saveei saveec errorInfo errorCode
  76
  77     set saveei $errorInfo
  78     set saveec $errorCode
  79
  80     puts ">$saveec|$saveei<"
  81 }
  82
  83 proc bgerror {msg} {
  84     global save
  85     logerror $msg
  86     saveeic
  87 }
  88
  89 proc onread {args} {
  90     global sock nick calling_nick errorInfo errorCode
  91
  92     if {[gets $sock line] == -1} { set terminate 1; return }
  93     regsub -all "\[^ -\176\240-\376\]" $line ? line
  94     set org $line
  95
  96     set ei $errorInfo
  97     set ec $errorCode
  98     catch { unset calling_nick }
  99     set errorInfo $ei
 100     set errorCode $ec
 101
 102     if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} {
 103         set line $remain
 104         if {[regexp {^([^!]+)!} $prefix dummy maybenick]} {
 105             set calling_nick $maybenick
 106             if {"[irctolower $maybenick]" == "[irctolower $nick]"} return
 107         }
 108     } else {
 109         set prefix {}
 110     }
 111     if {![string length $line]} { return }
 112     if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} {
 113         log "bad command: $org"
 114         return
 115     }
 116     set command [string toupper $command]
 117     set params {}
 118     while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} {
 119         lappend params $thisword
 120     }
 121     if {[regexp {^:(.*)} $line dummy thisword]} {
 122         lappend params $thisword
 123     } elseif {[string length $line]} {
 124         log "junk at end: $org"
 125         return
 126     }
 127     if {"$command" == "PRIVMSG" &&
 128         [regexp {^[&#+!]} [lindex $params 0]] &&
 129         ![regexp {^!} [lindex $params 1]]} {
 130         # on-channel message, ignore
 131         catch {
 132             recordlastseen_p $prefix "talking on [lindex $params 0]" 1
 133         }
 134         return
 135     }
 136     log "[clock seconds] <- $org"
 137     set procname msg_$command
 138     if {[catch { info body $procname }]} { return }
 139     if {[catch {
 140         eval [list $procname $prefix $command] $params
 141     } emsg]} {
 142         logerror "error: $emsg ($prefix $command $params)"
 143         saveeic
 144     }
 145 }
 146
 147 proc sendprivmsg {dest l} {
 148     foreach v [split $l "\n"] {
 149         sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $v
 150     }
 151 }
 152 proc sendaction {dest what} { sendout PRIVMSG $dest "\001ACTION $what\001" }
 153 proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } }
 154 proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] }
 155
 156 proc prefix_none {} {
 157     upvar 1 p p
 158     if {[string length $p]} { error "prefix specified" }
 159 }
 160
 161 proc msg_PING {p c s1} {
 162     prefix_none
 163     sendout PONG $s1
 164 }
 165
 166 proc check_nick {n} {
 167     if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" }
 168     if {[regexp {^[-0-9]} $n]} { error "bad nick start" }
 169 }
 170
 171 proc ischan {dest} {
 172     return [regexp {^[&#+!]} $dest]
 173 }
 174
 175 proc irctolower {v} {
 176     foreach {from to} [list "\\\[" "{" \
 177                           "\\\]" "}" \
 178                           "\\\\" "|" \
 179                           "~"    "^"] {
 180         regsub -all $from $v $to v
 181     }
 182     return [string tolower $v]
 183 }
 184
 185 proc prefix_nick {} {
 186     global nick
 187     upvar 1 p p
 188     upvar 1 n n
 189     if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" }
 190     check_nick $n
 191     if {"[irctolower $n]" == "[irctolower $nick]"} {
 192         error "from myself" {} {}
 193     }
 194 }
 195
 196 proc showintervalsecs {howlong} {
 197     return [showintervalsecs/[opt timeformat] $howlong]
 198 }
 199
 200 proc showintervalsecs/ks {howlong} {
 201     if {$howlong < 1000} {
 202         return "${howlong}s"
 203     } else {
 204         if {$howlong < 1000000} {
 205             set pfx k
 206             set scale 1000
 207         } else {
 208             set pfx M
 209             set scale 1000000
 210         }
 211         set value [expr "$howlong.0 / $scale"]
 212         foreach {min format} {100 %.0f 10 %.1f 1 %.2f} {
 213             if {$value < $min} continue
 214             return [format "$format${pfx}s" $value]
 215         }
 216     }
 217 }
 218
 219 proc format_qty {qty unit} {
 220     set o $qty
 221     append o " "
 222     append o $unit
 223     if {$qty != 1} { append o s }
 224     return $o
 225 }
 226
 227 proc showintervalsecs/hms {qty} {
 228     set ul {second 60 minute 60 hour 24 day 7 week}
 229     set remainv 0
 230     while {[llength $ul] > 1 && $qty >= [set uv [lindex $ul 1]]} {
 231         set remainu [lindex $ul 0]
 232         set remainv [expr {$qty % $uv}]
 233         set qty [expr {($qty-$remainv)/$uv}]
 234         set ul [lreplace $ul 0 1]
 235     }
 236     set o [format_qty $qty [lindex $ul 0]]
 237     if {$remainv} {
 238         append o " "
 239         append o [format_qty $remainv $remainu]
 240     }
 241     return $o
 242 }
 243
 244 proc showinterval {howlong} {
 245     if {$howlong <= 0} {
 246         return {just now}
 247     } else {
 248         return "[showintervalsecs $howlong] ago"
 249     }
 250 }
 251
 252 proc showtime {when} {
 253     return [showinterval [expr {[clock seconds] - $when}]]
 254 }
 255
 256 proc def_msgproc {name argl body} {
 257     proc msg_$name "varbase $argl" "\
 258     upvar #0 msg/\$varbase/dest d\n\
 259     upvar #0 msg/\$varbase/str s\n\
 260     upvar #0 msg/\$varbase/accum a\n\
 261 $body"
 262 }
 263
 264 def_msgproc begin {dest str} {
 265     set d $dest
 266     set s $str
 267     set a {}
 268 }
 269
 270 def_msgproc append {str} {
 271     set ns "$s$str"
 272     if {[string length $s] && [string length $ns] > 65} {
 273         msg__sendout $varbase
 274         set s " [string trimleft $str]"
 275     } else {
 276         set s $ns
 277     }
 278 }
 279
 280 def_msgproc finish {} {
 281     msg__sendout $varbase
 282     unset s
 283     unset d
 284     return $a
 285 }
 286
 287 def_msgproc _sendout {} {
 288     lappend a [string trimright $s]
 289     set s {}
 290 }
 291
 292 proc looking_whenwhere {when where} {
 293     set str [showtime [expr {$when-1}]]
 294     if {[string length $where]} { append str " on $where" }
 295     return $str
 296 }
 297
 298 proc recordlastseen_n {n how here} {
 299     global lastseen lookedfor
 300     set lastseen([irctolower $n]) [list $n [clock seconds] $how]
 301     if {!$here} return
 302     upvar #0 lookedfor([irctolower $n]) lf
 303     if {[info exists lf]} {
 304         switch -exact [llength $lf] {
 305             0 {
 306                 set ml {}
 307             }
 308             1 {
 309                 manyset [lindex $lf 0] when who where
 310                 set ml [list \
 311  "FYI, $who was looking for you [looking_whenwhere $when $where]."]
 312             }
 313             default {
 314                 msg_begin tosend $n "FYI, people have been looking for you:"
 315                 set i 0
 316                 set fin ""
 317                 foreach e $lf {
 318                     incr i
 319                     if {$i == 1} {
 320                         msg_append tosend " "
 321                     } elseif {$i == [llength $lf]} {
 322                         msg_append tosend " and "
 323                         set fin .
 324                     } else {
 325                         msg_append tosend ", "
 326                     }
 327                     manyset $e when who where
 328                     msg_append tosend \
 329                             "$who ([looking_whenwhere $when $where])$fin"
 330                 }
 331                 set ml [msg_finish tosend]
 332             }
 333         }
 334         unset lf
 335         msendprivmsg_delayed 1000 $n $ml
 336     }
 337 }
 338
 339 proc recordlastseen_p {p how here} {
 340     prefix_nick
 341     recordlastseen_n $n $how $here
 342 }
 343
 344 proc chanmode_arg {} {
 345     upvar 2 args cm_args
 346     set rv [lindex $cm_args 0]
 347     set cm_args [lreplace cm_args 0 0]
 348     return $rv
 349 }
 350
 351 proc chanmode_o1 {m g p chan} {
 352     global nick chan_initialop
 353     prefix_nick
 354     set who [chanmode_arg]
 355     recordlastseen_n $n "being nice to $who" 1
 356     if {"[irctolower $who]" == "[irctolower $nick]"} {
 357         set nl [irctolower $n]
 358         upvar #0 nick_unique($n) u
 359         if {[chandb_exists $chan]} {
 360             sendprivmsg $n Thanks.
 361         } elseif {![info exists u]} {
 362             sendprivmsg $n {Op me while not on the channel, why don't you ?}
 363         } else {
 364             set chan_initialop([irctolower $chan]) $u
 365             sendprivmsg $n \
 366  "Thanks. You can use `channel manager ...' to register this channel."
 367             if {![nickdb_exists $n] || ![string length [nickdb_get $n username]]} {
 368                 sendprivmsg $n \
 369  "(But to do that you must register your nick securely first.)"
 370             }
 371         }
 372     }
 373 }
 374
 375 proc chanmode_o0 {m g p chan} {
 376     global nick chandeop
 377     prefix_nick
 378     set who [chanmode_arg]
 379     recordlastseen_p $p "being mean to $who" 1
 380     if {"[irctolower $who]" == "[irctolower $nick]"} {
 381         set chandeop($chan) [list [clock seconds] $p]
 382     }
 383 }
 384
 385 proc msg_MODE {p c dest modelist args} {
 386     if {![ischan $dest]} return
 387     if {[regexp {^\-(.+)$} $modelist dummy modelist]} {
 388         set give 0
 389     } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} {
 390         set give 1
 391     } else {
 392         error "invalid modelist"
 393     }
 394     foreach m [split $modelist] {
 395         set procname chanmode_$m$give
 396         if {[catch { info body $procname }]} {
 397             recordlastseen_p $p "fiddling with $dest" 1
 398         } else {
 399             $procname $m $give  $p $dest
 400         }
 401     }
 402 }
 403
 404 proc channel_noone_seen {chan} {
 405     global nick_onchans
 406     foreach n [array names nick_onchans] {
 407         upvar #0 nick_onchans($n) oc
 408         set oc [grep tc {"$tc" != "$chan"} $oc]
 409     }
 410 }
 411
 412 proc process_kickpart {chan user} {
 413     global nick
 414     check_nick $user
 415     if {![ischan $chan]} { error "not a channel" }
 416     if {"[irctolower $user]" == "[irctolower $nick]"} {
 417         channel_noone_seen $chan
 418     }
 419     upvar #0 nick_onchans($user) oc
 420     set lc [irctolower $chan]
 421     set oc [grep tc {"$tc" != "$lc"} $oc]
 422     if {![llength $oc]} { nick_forget $user }
 423     nick_case $user
 424 }
 425
 426 proc msg_KICK {p c chans users comment} {
 427     set chans [split $chans ,]
 428     set users [split $users ,]
 429     if {[llength $chans] > 1} {
 430         foreach chan $chans user $users { process_kickpart $chan $user }
 431     } else {
 432         foreach user $users { process_kickpart [lindex $chans 0] $user }
 433     }
 434 }
 435
 436 proc msg_KILL {p c user why} {
 437     nick_forget $user
 438 }
 439
 440 set nick_counter 0
 441 set nick_arys {onchans username unique}
 442
 443 proc nick_forget {n} {
 444     global nick_arys
 445     foreach ary $nick_arys {
 446         upvar #0 nick_${ary}($n) av
 447         catch { unset av }
 448     }
 449     nick_case $n
 450 }
 451
 452 proc nick_case {n} {
 453     global nick_case
 454     set nick_case([irctolower $n]) $n
 455 }
 456
 457 proc msg_NICK {p c newnick} {
 458     global nick_arys nick_case
 459     prefix_nick
 460     recordlastseen_n $n "changing nicks to $newnick" 0
 461     recordlastseen_n $newnick "changing nicks from $n" 1
 462     foreach ary $nick_arys {
 463         upvar #0 nick_${ary}($n) old
 464         upvar #0 nick_${ary}($newnick) new
 465         if {[info exists new]} { error "nick collision ?! $ary $n $newnick" }
 466         if {[info exists old]} { set new $old; unset old }
 467     }
 468     nick_case $newnick
 469 }
 470
 471 proc nick_ishere {n} {
 472     global nick_counter
 473     upvar #0 nick_unique($n) u
 474     if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] }
 475     nick_case $n
 476 }
 477
 478 proc msg_JOIN {p c chan} {
 479     prefix_nick
 480     recordlastseen_n $n "joining $chan" 1
 481     upvar #0 nick_onchans($n) oc
 482     lappend oc [irctolower $chan]
 483     nick_ishere $n
 484 }
 485 proc msg_PART {p c chan} {
 486     prefix_nick
 487     recordlastseen_n $n "leaving $chan" 1
 488     process_kickpart $chan $n
 489 }
 490 proc msg_QUIT {p c why} {
 491     prefix_nick
 492     recordlastseen_n $n "leaving ($why)" 0
 493     nick_forget $n
 494 }
 495
 496 proc msg_PRIVMSG {p c dest text} {
 497     prefix_nick
 498     if {[ischan $dest]} {
 499         recordlastseen_n $n "invoking me in $dest" 1
 500         set output $dest
 501     } else {
 502         recordlastseen_n $n "talking to me" 1
 503         set output $n
 504     }
 505     nick_case $n
 506
 507     if {[catch {
 508         regsub {^! *} $text {} text
 509         set ucmd [ta_word]
 510         set procname ucmd/[string tolower $ucmd]
 511         if {[catch { info body $procname }]} {
 512             error "unknown command; try help for help"
 513         }
 514         $procname $p $dest
 515     } rv]} {
 516         sendprivmsg $n "error: $rv"
 517     } else {
 518         manyset $rv priv_msgs pub_msgs priv_acts pub_acts
 519         foreach {td val} [list $n $priv_acts $output $pub_acts] {
 520             foreach l [split $val "\n"] {
 521                 sendaction $td $l
 522             }
 523         }
 524         foreach {td val} [list $n $priv_msgs $output $pub_msgs] {
 525             foreach l [split $val "\n"] {
 526                 sendprivmsg $td $l
 527             }
 528         }
 529     }
 530 }
 531
 532 proc msg_INVITE {p c n chan} {
 533     after 1000 [list sendout JOIN $chan]
 534 }
 535
 536 proc grep {var predicate list} {
 537     set o {}
 538     upvar 1 $var v
 539     foreach v $list {
 540         if {[uplevel 1 [list expr $predicate]]} { lappend o $v }
 541     }
 542     return $o
 543 }
 544
 545 proc msg_353 {p c dest type chan nicklist} {
 546     global names_chans nick_onchans
 547     if {![info exists names_chans]} { set names_chans {} }
 548     set chan [irctolower $chan]
 549     lappend names_chans $chan
 550     channel_noone_seen $chan
 551     foreach n [split $nicklist { }] {
 552         regsub {^[@+]} $n {} n
 553         if {![string length $n]} continue
 554         check_nick $n
 555         upvar #0 nick_onchans($n) oc
 556         lappend oc $chan
 557         nick_ishere $n
 558     }
 559 }
 560
 561 proc msg_366 {p c args} {
 562     global names_chans nick_onchans
 563     if {[llength names_chans] > 1} {
 564         foreach n [array names nick_onchans] {
 565             upvar #0 nick_onchans($n) oc
 566             set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc]
 567             if {![llength $oc]} { nick_forget $n }
 568         }
 569     }
 570     unset names_chans
 571 }
 572
 573 proc ta_anymore {} {
 574     upvar 1 text text
 575     return [expr {!![string length $text]}]
 576 }
 577
 578 proc ta_nomore {} {
 579     upvar 1 text text
 580     if {[string length $text]} { error "too many parameters" }
 581 }
 582
 583 proc ta_word {} {
 584     upvar 1 text text
 585     if {![regexp {^([^  ]+) *(.*)} $text dummy firstword text]} {
 586         error "too few parameters"
 587     }
 588     return $firstword
 589 }
 590
 591 proc ta_nick {} {
 592     upvar 1 text text
 593     set v [ta_word]
 594     check_nick $v
 595     return $v
 596 }
 597
 598 proc def_ucmd {cmdname body} {
 599     proc ucmd/$cmdname {p dest} "    upvar 1 text text\n$body"
 600 }
 601
 602 proc ucmdr {priv pub args} {
 603     return -code return [concat [list $priv $pub] $args]
 604 }
 605
 606 proc loadhelp {} {
 607     global help_topics
 608
 609     catch { unset help_topics }
 610     set f [open helpinfos r]
 611     try_except_finally {
 612         set lno 0
 613         while {[gets $f l] >= 0} {
 614             incr lno
 615             if {[regexp {^#.*} $l]} {
 616             } elseif {[regexp {^ *$} $l]} {
 617                 if {[info exists topic]} {
 618                     set help_topics($topic) [join $lines "\n"]
 619                     unset topic
 620                     unset lines
 621                 }
 622             } elseif {[regexp {^!([-+._0-9a-z]*)$} $l dummy newtopic]} {
 623                 if {[info exists topic]} {
 624                     error "help $newtopic while in $topic"
 625                 }
 626                 set topic $newtopic
 627                 set lines {}
 628             } elseif {[regexp {^[^!#]} $l]} {
 629                 set topic
 630                 lappend lines [string trimright $l]
 631             } else {
 632                 error "eh ? $lno: $l"
 633             }
 634         }
 635         if {[info exists topic]} { error "unfinished topic $topic" }
 636     } {} {
 637         close $f
 638     }
 639 }
 640
 641 def_ucmd help {
 642     upvar #0 help_topics([irctolower [string trim $text]]) info
 643     if {![info exists info]} { ucmdr "No help on $text, sorry." {} }
 644     ucmdr $info {}
 645 }
 646
 647 def_ucmd ? {
 648     global help_topics
 649     ucmdr $help_topics() {}
 650 }
 651
 652 proc check_username {target} {
 653     if {
 654         [string length $target] > 8 ||
 655         [regexp {[^-0-9a-z]} $target] ||
 656         ![regexp {^[a-z]} $target]
 657     } { error "invalid username" }
 658 }
 659
 660 proc somedb__head {} {
 661     uplevel 1 {
 662         set idl [irctolower $id]
 663         upvar #0 ${nickchan}db($idl) ndbe
 664         binary scan $idl H* idh
 665         set idfn $fprefix$idh
 666         if {![info exists iddbe] && [file exists $idfn]} {
 667             set f [open $idfn r]
 668             try_except_finally { set newval [read $f] } {} { close $f }
 669             if {[llength $newval] % 2} { error "invalid length" }
 670             set iddbe $newval
 671         }
 672     }
 673 }
 674
 675 proc def_somedb {name arglist body} {
 676     foreach {nickchan fprefix} {nick users/n chan chans/c} {
 677         proc ${nickchan}db_$name $arglist \
 678                 "set nickchan $nickchan; set fprefix $fprefix; somedb__head; $body"
 679     }
 680 }
 681
 682 def_somedb exists {id} {
 683     return [info exists iddbe]
 684 }
 685
 686 def_somedb delete {id} {
 687     catch { unset iddbe }
 688     file delete $idfn
 689 }
 690
 691 set default_settings_nick {timeformat ks}
 692 set default_settings_chan {autojoin 1}
 693
 694 def_somedb set {id args} {
 695     upvar #0 default_settings_$nickchan def
 696     if {![info exists iddbe]} { set iddbe $def }
 697     foreach {key value} [concat $iddbe $args] { set a($key) $value }
 698     set newval {}
 699     foreach {key value} [array get a] { lappend newval $key $value }
 700     set f [open $idfn.new w]
 701     try_except_finally {
 702         puts $f $newval
 703         close $f
 704         file rename -force $idfn.new $idfn
 705     } {
 706     } {
 707         catch { close $f }
 708     }
 709     set iddbe $newval
 710 }
 711
 712 def_somedb get {id key} {
 713     upvar #0 default_settings_$nickchan def
 714     if {[info exists iddbe]} {
 715         set l $iddbe
 716     } else {
 717         set l $def
 718     }
 719     foreach {tkey value} $l {
 720         if {"$tkey" == "$key"} { return $value }
 721     }
 722     error "unset setting $key"
 723 }
 724
 725 proc opt {key} {
 726     global calling_nick
 727     if {[info exists calling_nick]} { set n $calling_nick } { set n {} }
 728     return [nickdb_get $n $key]
 729 }
 730
 731 proc check_notonchan {} {
 732     upvar 1 dest dest
 733     if {[ischan $dest]} { error "that command must be sent privately" }
 734 }
 735
 736 proc nick_securitycheck {strict} {
 737     upvar 1 n n
 738     if {![nickdb_exists $n]} { error "you are unknown to me, use `register'." }
 739     set wantu [nickdb_get $n username]
 740     if {![string length $wantu]} {
 741         if {$strict} {
 742             error "that feature is only available to secure users, sorry."
 743         } else {
 744             return
 745         }
 746     }
 747     upvar #0 nick_username($n) nu
 748     if {![info exists nu]} {
 749         error "nick $n is secure, you must identify yourself first."
 750     }
 751     if {"$wantu" != "$nu"} {
 752         error "you are the wrong user - the nick $n belongs to $wantu, not $nu"
 753     }
 754 }
 755
 756 proc channel_securitycheck {channel n} {
 757     # You must also call `nick_securitycheck 1'
 758     set mgrs [chandb_get $channel managers]
 759     if {[lsearch -exact [irctolower $mgrs] [irctolower $n]] < 0} {
 760         error "you are not a manager of $channel"
 761     }
 762 }
 763
 764 proc def_chancmd {name body} {
 765     proc channel/$name {} \
 766             "    upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body"
 767 }
 768
 769 def_chancmd manager {
 770     set opcode [ta_word]
 771     switch -exact _$opcode {
 772         _= { set ml {} }
 773         _+ - _- {
 774             if {[chandb_exists $chan]} {
 775                 set ml [chandb_get $chan managers]
 776             } else {
 777                 set ml [list [irctolower $n]]
 778             }
 779         }
 780         default {
 781             error "`channel manager' opcode must be one of + - ="
 782         }
 783     }
 784     foreach nn [split $text " "] {
 785         if {![string length $nn]} continue
 786         check_nick $nn
 787         set nn [irctolower $nn]
 788         if {"$opcode" != "-"} {
 789             lappend ml $nn
 790         } else {
 791             set ml [grep nq {"$nq" != "$nn"} $ml]
 792         }
 793     }
 794     if {[llength $ml]} {
 795         chandb_set $chan managers $ml
 796         ucmdr "Managers of $chan: $ml" {}
 797     } else {
 798         chandb_delete $chan
 799         ucmdr {} {} "forgets about managing $chan." {}
 800     }
 801 }
 802
 803 def_chancmd autojoin {
 804     set yesno [ta_word]
 805     switch -exact [string tolower $yesno] {
 806         no { set nv 0 }
 807         yes { set nv 1 }
 808         default { error "channel autojoin must be `yes' or `no' }
 809     }
 810     chandb_set $chan autojoin $nv
 811 }
 812
 813 def_chancmd show {
 814     if {[chandb_exists $chan]} {
 815         set l "Settings for $chan: autojoin "
 816         append l [lindex {no yes} [chandb_get $chan autojoin]]
 817         append l "\nManagers: "
 818         append l [join [chandb_get $chan managers] " "]
 819         ucmdr {} $l
 820     } else {
 821         ucmdr {} "The channel $chan is not managed."
 822     }
 823 }
 824
 825 def_ucmd op {
 826     if {[ischan $dest]} { set target $dest }
 827     if {[ta_anymore]} { set target [ta_word] }
 828     ta_nomore
 829     if {![info exists target]} { error "you must specify, or !... on, the channel" }
 830     if {![ischan $target]} { error "not a valid channel" }
 831     if {![chandb_exists $target]} { error "$target is not a managed channel." }
 832     prefix_nick
 833     nick_securitycheck 1
 834     channel_securitycheck $target $n
 835     sendout MODE $target +o $n
 836 }
 837
 838 def_ucmd channel {
 839     if {[ischan $dest]} { set target $dest }
 840     if {![ta_anymore]} {
 841         set subcmd show
 842     } else {
 843         set subcmd [ta_word]
 844     }
 845     if {[ischan $subcmd]} {
 846         set target $subcmd
 847         if {![ta_anymore]} {
 848             set subcmd show
 849         } else {
 850             set subcmd [ta_word]
 851         }
 852     }
 853     if {![info exists target]} { error "privately, you must specify a channel" }
 854     set procname channel/$subcmd
 855     if {"$subcmd" != "show"} {
 856         if {[catch { info body $procname }]} { error "unknown channel setting $subcmd" }
 857         prefix_nick
 858         nick_securitycheck 1
 859         if {[chandb_exists $target]} {
 860             channel_securitycheck $target $n
 861         } else {
 862             upvar #0 chan_initialop([irctolower $target]) io
 863             upvar #0 nick_unique($n) u
 864             if {![info exists io]} { error "$target is not a managed channel" }
 865             if {"$io" != "$u"} { error "you are not the interim manager of $target" }
 866             if {"$subcmd" != "manager"} { error "use `channel manager' first" }
 867         }
 868     }
 869     channel/$subcmd
 870 }
 871
 872 def_ucmd who {
 873     if {[ta_anymore]} {
 874         set target [ta_word]; ta_nomore
 875         set myself 1
 876     } else {
 877         prefix_nick
 878         set target $n
 879         set myself [expr {"$target" != "$n"}]
 880     }
 881     upvar #0 nick_case([irctolower $target]) nc
 882     set nshow $target
 883     if {[info exists nc]} {
 884         upvar #0 nick_onchans($nc) oc
 885         upvar #0 nick_username($nc) nu
 886         if {[info exists oc]} { set nshow $nc }
 887     }
 888     if {![nickdb_exists $target]} {
 889         set ol "$nshow is not a registered nick."
 890     } elseif {[string length [set username [nickdb_get $target username]]]} {
 891         set ol "The nick $nshow belongs to the user $username."
 892     } else {
 893         set ol "The nick $nshow is registered (but not to a username)."
 894     }
 895     if {![info exists nc] || ![info exists oc]} {
 896         if {$myself} {
 897             append ol "\nI can't see $nshow on anywhere."
 898         } else {
 899             append ol "\nYou aren't on any channels with me."
 900         }
 901     } elseif {![info exists nu]} {
 902         append ol "\n$nshow has not identified themselves."
 903     } elseif {![info exists username]} {
 904         append ol "\n$nshow has identified themselves as the user $nu."
 905     } elseif {"$nu" != "$username"} {
 906         append ol "\nHowever, $nshow is being used by the user $nu."
 907     } else {
 908         append ol "\n$nshow has identified themselves to me."
 909     }
 910     ucmdr {} $ol
 911 }
 912
 913 def_ucmd register {
 914     prefix_nick
 915     check_notonchan
 916     set old [nickdb_exists $n]
 917     if {$old} { nick_securitycheck 0 }
 918     switch -exact [string tolower [string trim $text]] {
 919         {} {
 920             upvar #0 nick_username($n) nu
 921             if {![info exists nu]} {
 922                 ucmdr {} \
 923  "You must identify yourself before using `register'.  See `help identify', or use `register insecure'."
 924             }
 925             nickdb_set $n username $nu
 926             ucmdr {} {} "makes a note of your username." {}
 927         }
 928         delete {
 929             nickdb_delete $n
 930             ucmdr {} {} "forgets your nickname." {}
 931         }
 932         insecure {
 933             nickdb_set $n username {}
 934             if {$old} {
 935                 ucmdr {} "Security is now disabled for your nickname !"
 936             } else {
 937                 ucmdr {} "This is fine, but bear in mind that people will be able to mess with your settings.  Channel management features need a secure registration." "makes an insecure registration for your nick."
 938             }
 939         }
 940     }
 941 }
 942
 943 proc timeformat_desc {tf} {
 944     switch -exact $tf {
 945         ks { return "Times will be displayed in seconds or kiloseconds." }
 946         hms { return "Times will be displayed in hours, minutes, etc." }
 947         default { error "invalid timeformat: $v" }
 948     }
 949 }
 950
 951 proc def_setting {opt show_body set_body} {
 952     proc set_show/$opt {} "
 953         upvar 1 n n
 954         set opt $opt
 955         $show_body"
 956     if {![string length $set_body]} return
 957     proc set_set/$opt {} "
 958         upvar 1 n n
 959         upvar 1 text text
 960         set opt $opt
 961         $set_body"
 962 }
 963
 964 def_setting timeformat {
 965     set tf [nickdb_get $n timeformat]
 966     return "$tf: [timeformat_desc $tf]"
 967 } {
 968     set tf [string tolower [ta_word]]
 969     ta_nomore
 970     set desc [timeformat_desc $tf]
 971     nickdb_set $n timeformat $tf
 972     ucmdr {} $desc
 973 }
 974
 975 def_setting security {
 976     set s [nickdb_get $n username]
 977     if {[string length $s]} {
 978         return "Your nick, $n, is controlled by the user $s."
 979     } else {
 980         return "Your nick, $n, is not secure."
 981     }
 982 } {}
 983
 984 def_ucmd set {
 985     prefix_nick
 986     check_notonchan
 987     if {![nickdb_exists $n]} {
 988         ucmdr {} "You are unknown to me and so have no settings.  (Use `register'.)"
 989     }
 990     if {![ta_anymore]} {
 991         set ol {}
 992         foreach proc [lsort [info procs]] {
 993             if {![regexp {^set_show/(.*)$} $proc dummy opt]} continue
 994             lappend ol [format "%-10s %s" $opt [set_show/$opt]]
 995         }
 996         ucmdr {} [join $ol "\n"]
 997     } else {
 998         set opt [ta_word]
 999         if {[catch { info body set_show/$opt }]} {
1000             error "no setting $opt"
1001         }
1002         if {![ta_anymore]} {
1003             ucmdr {} "$opt [set_show/$opt]"
1004         } else {
1005             nick_securitycheck 0
1006             if {[catch { info body set_set/$opt }]} {
1007                 error "setting $opt cannot be set with `set'"
1008             }
1009             set_set/$opt
1010         }
1011     }
1012 }
1013
1014 def_ucmd identpass {
1015     set username [ta_word]
1016     set passmd5 [md5sum "[ta_word]\n"]
1017     ta_nomore
1018     prefix_nick
1019     check_notonchan
1020     upvar #0 nick_onchans($n) onchans
1021     if {![info exists onchans] || ![llength $onchans]} {
1022         ucmdr "You must be on a channel with me to identify yourself." {}
1023     }
1024     check_username $username
1025     exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \
1026             irc-identpass $n
1027     upvar #0 nick_username($n) rec_username
1028     set rec_username $username
1029     ucmdr "Pleased to see you, $username." {}
1030 }
1031
1032 def_ucmd summon {
1033     set target [ta_word]
1034     ta_nomore
1035     check_username $target
1036     prefix_nick
1037
1038     upvar #0 lastsummon($target) ls
1039     set now [clock seconds]
1040     if {[info exists ls]} {
1041         set interval [expr {$now - $ls}]
1042         if {$interval < 30} {
1043             ucmdr {} \
1044  "Please be patient; $target was summoned only [showinterval $interval]."
1045         }
1046     }
1047     regsub {^[^!]*!} $p {} path
1048     if {[catch {
1049         exec userv --timeout 3 $target irc-summon $n $path \
1050                 [expr {[ischan $dest] ? "$dest" : ""}] \
1051                 < /dev/null
1052     } rv]} {
1053         regsub -all "\n" $rv { / } rv
1054         error $rv
1055     }
1056     if {[regexp {^problem (.*)} $rv dummy problem]} {
1057         ucmdr {} "The user `$target' $problem."
1058     } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} {
1059         set idletime [expr {$now - $idlesince}]
1060         set ls $now
1061         ucmdr {} {} {} "invites $target ($tty[expr {
1062             $idletime > 10 ? ", idle for [showintervalsecs $idletime]" : ""
1063         }]) to [expr {
1064             [ischan $dest] ? "join us here" : "talk to you"
1065         }]."
1066     } else {
1067         error "unexpected response from userv service: $rv"
1068     }
1069 }
1070
1071 proc md5sum {value} { exec md5sum << $value }
1072
1073 def_ucmd seen {
1074     global lastseen nick
1075     prefix_nick
1076     set ncase [ta_nick]
1077     set nlower [irctolower $ncase]
1078     ta_nomore
1079     set now [clock seconds]
1080     if {"$nlower" == "[irctolower $nick]"} {
1081         error "I am not self-aware."
1082     } elseif {![info exists lastseen($nlower)]} {
1083         set rstr "I've never seen $ncase."
1084     } else {
1085         manyset $lastseen($nlower) realnick time what
1086         set howlong [expr {$now - $time}]
1087         set string [showinterval $howlong]
1088         set rstr "I last saw $realnick $string, $what."
1089     }
1090     if {[ischan $dest]} {
1091         set where $dest
1092     } else {
1093         set where {}
1094     }
1095     upvar #0 lookedfor($nlower) lf
1096     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
1097     set lf [list [list $now $n $where]]
1098     foreach v $oldvalue {
1099         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
1100         lappend lf $v
1101     }
1102     ucmdr {} $rstr
1103 }
1104
1105 if {![info exists sock]} {
1106     set sock [socket $host $port]
1107     fconfigure $sock -buffering line
1108     #fconfigure $sock -translation binary
1109     fconfigure $sock -translation crlf
1110
1111     sendout USER blight 0 * $ownfullname
1112     sendout NICK $nick
1113     fileevent $sock readable onread
1114 }
1115
1116 loadhelp
1117
1118 #if {![regexp {tclsh} $argv0]} {
1119 #    vwait terminate
1120 #}