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