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

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