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