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