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