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

   1 # Core bot code
   2
   3 proc defset {varname val} {
   4     upvar #0 $varname var
   5     if {![info exists var]} { set var $val }
   6 }
   7
   8 # must set host
   9 defset port 6667
  10
  11 defset nick testbot
  12 defset ownfullname "testing bot"
  13 defset ownmailaddr test-irc-bot@example.com
  14
  15 defset musthaveping_ms 10000
  16 defset out_maxburst 6
  17 defset out_interval 2100
  18 defset out_lag_lag 5000
  19 defset out_lag_very 25000
  20
  21 defset marktime_min 300
  22 defset marktime_join_startdelay 5000
  23
  24 proc manyset {list args} {
  25     foreach val $list var $args {
  26         upvar 1 $var my
  27         set my $val
  28     }
  29 }
  30
  31 proc try_except_finally {try except finally} {
  32     global errorInfo errorCode
  33     set er [catch { uplevel 1 $try } emsg]
  34     if {$er} {
  35         set ei $errorInfo
  36         set ec $errorCode
  37         if {[catch { uplevel 1 $except } emsg3]} {
  38             append ei "\nALSO ERROR HANDLING ERROR:\n$emsg3"
  39         }
  40     }
  41     set er2 [catch { uplevel 1 $finally } emsg2]
  42     if {$er} {
  43         if {$er2} {
  44             append ei "\nALSO ERROR CLEANING UP:\n$emsg2"
  45         }
  46         return -code $er -errorinfo $ei -errorcode $ec $emsg
  47     } elseif {$er2} {
  48         return -code $er2 -errorinfo $errorInfo -errorcode $errorCode $emsg2
  49     } else {
  50         return $emsg
  51     }
  52 }
  53
  54 proc out__vars {} {
  55     uplevel 1 {
  56         global out_queue out_creditms out_creditat out_interval out_maxburst
  57         global out_lag_lag out_lag_very
  58 #set pr [lindex [info level 0] 0]
  59 #puts $pr>[clock seconds]|$out_creditat|$out_creditms|[llength $out_queue]<
  60     }
  61 }
  62
  63 proc out_lagged {} {
  64     out__vars
  65     if {[llength $out_queue]*$out_interval > $out_lag_very} {
  66         return 2
  67     } elseif {[llength $out_queue]*$out_interval > $out_lag_lag} {
  68         return 1
  69     } else {
  70         return 0
  71     }
  72 }
  73
  74 proc out_restart {} {
  75     out__vars
  76
  77     set now [clock seconds]
  78     incr out_creditms [expr {($now - $out_creditat) * 1000}]
  79     set out_creditat $now
  80     if {$out_creditms > $out_maxburst*$out_interval} {
  81         set out_creditms [expr {$out_maxburst*$out_interval}]
  82     }
  83     out_runqueue $now
  84 }
  85
  86 proc out_runqueue {now} {
  87     global sock
  88     out__vars
  89
  90     while {[llength $out_queue] && $out_creditms >= $out_interval} {
  91 #puts rq>$now|$out_creditat|$out_creditms|[llength $out_queue]<
  92         manyset [lindex $out_queue 0] orgwhen msg
  93         set out_queue [lrange $out_queue 1 end]
  94         if {[llength $out_queue]} {
  95             append orgwhen "+[expr {$now - $orgwhen}]"
  96             append orgwhen "([llength $out_queue])"
  97         }
  98         puts "$orgwhen -> $msg"
  99         puts $sock $msg
 100         incr out_creditms -$out_interval
 101     }
 102     if {[llength $out_queue]} {
 103         after $out_interval out_nextmessage
 104     }
 105 }
 106
 107 proc out_nextmessage {} {
 108     out__vars
 109     set now [clock seconds]
 110     incr out_creditms $out_interval
 111     set out_creditat $now
 112     out_runqueue $now
 113 }
 114
 115 proc sendout_priority {priority command args} {
 116     global sock out_queue
 117     if {[llength $args]} {
 118         set la [lindex $args end]
 119         set args [lreplace $args end end]
 120         foreach i $args {
 121             if {[regexp {[: ]} $i]} {
 122                 error "bad argument in output $i ($command $args)"
 123             }
 124         }
 125         lappend args :$la
 126     }
 127     set args [lreplace $args 0 -1 $command]
 128     set string [join $args { }]
 129     set now [clock seconds]
 130     set newe [list $now $string]
 131     if {$priority} {
 132         set out_queue [concat [list $newe] $out_queue]
 133     } else {
 134         lappend out_queue $newe
 135     }
 136     if {[llength $out_queue] == 1} {
 137         out_restart
 138     }
 139 }
 140
 141 proc sendout {command args} { eval sendout_priority [list 0 $command] $args }
 142
 143 proc log {data} {
 144     puts $data
 145 }
 146
 147 proc logerror {data} {
 148     log $data
 149 }
 150
 151 proc saveeic {} {
 152     global saveei saveec errorInfo errorCode
 153
 154     set saveei $errorInfo
 155     set saveec $errorCode
 156
 157     puts ">$saveec|$saveei<"
 158 }
 159
 160 proc bgerror {msg} {
 161     global save
 162     logerror $msg
 163     saveeic
 164 }
 165
 166 proc onread {args} {
 167     global sock nick calling_nick errorInfo errorCode
 168
 169     if {[gets $sock line] == -1} { fail "EOF/error on input" }
 170     regsub -all "\[^ -\176\240-\376\]" $line ? line
 171     set org $line
 172
 173     set ei $errorInfo
 174     set ec $errorCode
 175     catch { unset calling_nick }
 176     set errorInfo $ei
 177     set errorCode $ec
 178
 179     if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} {
 180         set line $remain
 181         if {[regexp {^([^!]+)!} $prefix dummy maybenick]} {
 182             set calling_nick $maybenick
 183             if {"[irctolower $maybenick]" == "[irctolower $nick]"} return
 184         }
 185     } else {
 186         set prefix {}
 187     }
 188     if {![string length $line]} { return }
 189     if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} {
 190         log "bad command: $org"
 191         return
 192     }
 193     set command [string toupper $command]
 194     set params {}
 195     while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} {
 196         lappend params $thisword
 197     }
 198     if {[regexp {^:(.*)} $line dummy thisword]} {
 199         lappend params $thisword
 200     } elseif {[string length $line]} {
 201         log "junk at end: $org"
 202         return
 203     }
 204     if {"$command" == "PRIVMSG" &&
 205         [regexp {^[&#+!]} [lindex $params 0]] &&
 206         ![regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} {
 207         # on-channel message, ignore
 208         set chan [lindex $params 0]
 209         upvar #0 chan_lastactivity([irctolower $chan]) la
 210         set la [clock seconds]
 211         catch { recordlastseen_p $prefix "talking on $chan" 1 }
 212         return
 213     }
 214     log "[clock seconds] <- $org"
 215     set procname msg_$command
 216     if {[catch { info body $procname }]} { return }
 217     if {[catch {
 218         eval [list $procname $prefix $command] $params
 219     } emsg]} {
 220         logerror "error: $emsg ($prefix $command $params)"
 221         saveeic
 222     }
 223 }
 224
 225 proc sendprivmsg {dest l} {
 226     foreach v [split $l "\n"] {
 227         sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $v
 228     }
 229 }
 230 proc sendaction_priority {priority dest what} {
 231     sendout_priority $priority PRIVMSG $dest "\001ACTION $what\001"
 232 }
 233 proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } }
 234 proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] }
 235
 236 proc prefix_none {} {
 237     upvar 1 p p
 238     if {[string length $p]} { error "prefix specified" }
 239 }
 240
 241 proc msg_PING {p c s1} {
 242     global musthaveping_after
 243     prefix_none
 244     sendout PONG $s1
 245     if {[info exists musthaveping_after]} connected
 246 }
 247
 248 proc check_nick {n} {
 249     if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" }
 250     if {[regexp {^[-0-9]} $n]} { error "bad nick start" }
 251 }
 252
 253 proc ischan {dest} {
 254     return [regexp {^[&#+!]} $dest]
 255 }
 256
 257 proc irctolower {v} {
 258     foreach {from to} [list "\\\[" "{" \
 259                           "\\\]" "}" \
 260                           "\\\\" "|" \
 261                           "~"    "^"] {
 262         regsub -all $from $v $to v
 263     }
 264     return [string tolower $v]
 265 }
 266
 267 proc prefix_nick {} {
 268     global nick
 269     upvar 1 p p
 270     upvar 1 n n
 271     if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" }
 272     check_nick $n
 273     if {"[irctolower $n]" == "[irctolower $nick]"} {
 274         error "from myself" {} {}
 275     }
 276 }
 277
 278 proc showintervalsecs {howlong abbrev} {
 279     return [showintervalsecs/[opt timeformat] $howlong $abbrev]
 280 }
 281
 282 proc showintervalsecs/ks {howlong abbrev} {
 283     if {$howlong < 1000} {
 284         return "${howlong}s"
 285     } else {
 286         if {$howlong < 1000000} {
 287             set pfx k
 288             set scale 1000
 289         } else {
 290             set pfx M
 291             set scale 1000000
 292         }
 293         set value [expr "$howlong.0 / $scale"]
 294         foreach {min format} {100 %.0f 10 %.1f 1 %.2f} {
 295             if {$value < $min} continue
 296             return [format "$format${pfx}s" $value]
 297         }
 298     }
 299 }
 300
 301 proc format_qty {qty unit abbrev} {
 302     set o $qty
 303     if {$abbrev} {
 304         append o [string range $unit 0 0]
 305     } else {
 306         append o " "
 307         append o $unit
 308         if {$qty != 1} { append o s }
 309     }
 310     return $o
 311 }
 312
 313 proc showintervalsecs/hms {qty abbrev} {
 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] $abbrev]
 323     if {$remainv} {
 324         if {!$abbrev} { append o " " }
 325         append o [format_qty $remainv $remainu $abbrev]
 326     }
 327     return $o
 328 }
 329
 330 proc showinterval {howlong} {
 331     if {$howlong <= 0} {
 332         return {just now}
 333     } else {
 334         return "[showintervalsecs $howlong 0] 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 note_topic {showoff whoby topic} {
 426     set msg "FYI, $whoby has changed the topic on $showoff"
 427     if {[string length $topic] < 160} {
 428         append msg " to $topic"
 429     } else {
 430         append msg " but it is too long to reproduce here !"
 431     }
 432     set showoff [irctolower $showoff]
 433     set tell [chandb_get $showoff topictell]
 434     if {[lsearch -exact $tell *] >= 0} {
 435         set tryspies [chandb_list]
 436     } else {
 437         set tryspies $tell
 438     }
 439     foreach spy $tryspies {
 440         set see [chandb_get $spy topicsee]
 441         if {[lsearch -exact $see $showoff] >= 0 || \
 442                 ([lsearch -exact $see *] >= 0 && \
 443                 [lsearch -exact $tell $spy] >= 0)} {
 444             sendprivmsg $spy $msg
 445         }
 446     }
 447 }
 448
 449 proc recordlastseen_p {p how here} {
 450     prefix_nick
 451     recordlastseen_n $n $how $here
 452 }
 453
 454 proc chanmode_arg {} {
 455     upvar 2 args cm_args
 456     set rv [lindex $cm_args 0]
 457     set cm_args [lreplace cm_args 0 0]
 458     return $rv
 459 }
 460
 461 proc chanmode_o1 {m g p chan} {
 462     global nick chan_initialop
 463     prefix_nick
 464     set who [chanmode_arg]
 465     recordlastseen_n $n "being nice to $who" 1
 466     if {"[irctolower $who]" == "[irctolower $nick]"} {
 467         set nlower [irctolower $n]
 468         upvar #0 nick_unique($nlower) u
 469         if {[chandb_exists $chan]} {
 470             sendprivmsg $n Thanks.
 471         } elseif {![info exists u]} {
 472             sendprivmsg $n {Op me while not on the channel, why don't you ?}
 473         } else {
 474             set chan_initialop([irctolower $chan]) $u
 475             sendprivmsg $n \
 476  "Thanks. You can use `channel manager ...' to register this channel."
 477             if {![nickdb_exists $n] || ![string length [nickdb_get $n username]]} {
 478                 sendprivmsg $n \
 479  "(But to do that you must register your nick securely first.)"
 480             }
 481         }
 482     }
 483 }
 484
 485 proc chanmode_o0 {m g p chan} {
 486     global nick chandeop
 487     prefix_nick
 488     set who [chanmode_arg]
 489     recordlastseen_p $p "being mean to $who" 1
 490     if {"[irctolower $who]" == "[irctolower $nick]"} {
 491         set chandeop($chan) [list [clock seconds] $p]
 492     }
 493 }
 494
 495 proc msg_MODE {p c dest modelist args} {
 496     if {![ischan $dest]} return
 497     if {[regexp {^\-(.+)$} $modelist dummy modelist]} {
 498         set give 0
 499     } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} {
 500         set give 1
 501     } else {
 502         error "invalid modelist"
 503     }
 504     foreach m [split $modelist] {
 505         set procname chanmode_$m$give
 506         if {[catch { info body $procname }]} {
 507             recordlastseen_p $p "fiddling with $dest" 1
 508         } else {
 509             $procname $m $give  $p $dest
 510         }
 511     }
 512 }
 513
 514 proc leaving {lchan} {
 515     foreach luser [array names nick_onchans] {
 516         upvar #0 nick_onchans($luser) oc
 517         set oc [grep tc {"$tc" != "$lchan"} $oc]
 518     }
 519     upvar #0 chan_nicks($lchan) nlist
 520     unset nlist
 521     upvar #0 chan_lastactivity($lchan) la
 522     catch { unset la }
 523 }
 524
 525 proc doleave {lchan} {
 526     sendout PART $lchan
 527     leaving $lchan
 528 }
 529
 530 proc dojoin {lchan} {
 531     global chan_nicks
 532     sendout JOIN $lchan
 533     set chan_nicks($lchan) {}
 534 }
 535
 536 proc check_justme {lchan} {
 537     global nick
 538     upvar #0 chan_nicks($lchan) nlist
 539     if {[llength $nlist] != 1} return
 540     if {"[lindex $nlist 0]" != "[irctolower $nick]"} return
 541     if {[chandb_exists $lchan]} {
 542         set mode [chandb_get $lchan mode]
 543         if {"$mode" != "*"} {
 544             sendout MODE $lchan $mode
 545         }
 546         set topic [chandb_get $lchan topicset]
 547         if {[string length $topic]} {
 548             sendout TOPIC $lchan $topic
 549         }
 550     } else {
 551         doleave $lchan
 552     }
 553 }
 554
 555 proc process_kickpart {chan user} {
 556     global nick
 557     check_nick $user
 558     set luser [irctolower $user]
 559     set lchan [irctolower $chan]
 560     if {![ischan $chan]} { error "not a channel" }
 561     if {"$luser" == "[irctolower $nick]"} {
 562         leaving $lchan
 563     } else {
 564         upvar #0 nick_onchans($luser) oc
 565         upvar #0 chan_nicks($lchan) nlist
 566         set oc [grep tc {"$tc" != "$lchan"} $oc]
 567         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 568         nick_case $user
 569         if {![llength $oc]} {
 570             nick_forget $luser
 571         } else {
 572             check_justme $lchan
 573         }
 574     }
 575 }
 576
 577 proc msg_TOPIC {p c dest topic} {
 578     prefix_nick
 579     if {![ischan $dest]} return
 580     recordlastseen_n $n "changing the topic on $dest" 1
 581     note_topic [irctolower $dest] $n $topic
 582 }
 583
 584 proc msg_KICK {p c chans users comment} {
 585     set chans [split $chans ,]
 586     set users [split $users ,]
 587     if {[llength $chans] > 1} {
 588         foreach chan $chans user $users { process_kickpart $chan $user }
 589     } else {
 590         foreach user $users { process_kickpart [lindex $chans 0] $user }
 591     }
 592 }
 593
 594 proc msg_KILL {p c user why} {
 595     nick_forget $user
 596 }
 597
 598 set nick_counter 0
 599 set nick_arys {onchans username unique}
 600 # nick_onchans($luser) -> [list ... $lchan ...]
 601 # nick_username($luser) -> <securely known local username>
 602 # nick_unique($luser) -> <counter>
 603 # nick_case($luser) -> $user  (valid even if no longer visible)
 604 # nick_markid($luser) -> <after id for marktime>
 605
 606 # chan_nicks($lchan) -> [list ... $luser ...]
 607 # chan_lastactivity($lchan) -> [clock seconds]
 608
 609 proc lnick_forget {luser} {
 610     global nick_arys chan_nicks
 611     lnick_marktime_cancel $luser
 612     foreach ary $nick_arys {
 613         upvar #0 nick_${ary}($luser) av
 614         catch { unset av }
 615     }
 616     foreach lch [array names chan_nicks] {
 617         upvar #0 chan_nicks($lch) nlist
 618         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 619         check_justme $lch
 620     }
 621 }
 622
 623 proc nick_forget {user} {
 624     global nick_arys chan_nicks
 625     lnick_forget [irctolower $user]
 626     nick_case $user
 627 }
 628
 629 proc nick_case {user} {
 630     global nick_case
 631     set nick_case([irctolower $user]) $user
 632 }
 633
 634 proc msg_NICK {p c newnick} {
 635     global nick_arys nick_case
 636     prefix_nick
 637     recordlastseen_n $n "changing nicks to $newnick" 0
 638     recordlastseen_n $newnick "changing nicks from $n" 1
 639     set luser [irctolower $n]
 640     lnick_marktime_cancel $luser
 641     set lusernew [irctolower $newnick]
 642     foreach ary $nick_arys {
 643         upvar #0 nick_${ary}($luser) old
 644         upvar #0 nick_${ary}($lusernew) new
 645         if {[info exists new]} { error "nick collision ?! $ary $n $newnick" }
 646         if {[info exists old]} { set new $old; unset old }
 647     }
 648     upvar #0 nick_onchans($lusernew) oc
 649     foreach ch $oc {
 650         upvar #0 chan_nicks($ch) nlist
 651         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 652         lappend nlist $lusernew
 653     }
 654     lnick_marktime_start $lusernew "Hi." 500
 655     nick_case $newnick
 656 }
 657
 658 proc nick_ishere {n} {
 659     global nick_counter
 660     upvar #0 nick_unique([irctolower $n]) u
 661     if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] }
 662     nick_case $n
 663 }
 664
 665 proc msg_JOIN {p c chan} {
 666     prefix_nick
 667     recordlastseen_n $n "joining $chan" 1
 668     set nl [irctolower $n]
 669     set lchan [irctolower $chan]
 670     upvar #0 nick_onchans($nl) oc
 671     upvar #0 chan_nicks($lchan) nlist
 672     if {![info exists oc]} {
 673         global marktime_join_startdelay
 674         lnick_marktime_start $nl "Welcome." $marktime_join_startdelay
 675     }
 676     lappend oc $lchan
 677     lappend nlist $nl
 678     nick_ishere $n
 679 }
 680 proc msg_PART {p c chan} {
 681     prefix_nick
 682     recordlastseen_n $n "leaving $chan" 1
 683     process_kickpart $chan $n
 684 }
 685 proc msg_QUIT {p c why} {
 686     prefix_nick
 687     recordlastseen_n $n "leaving ($why)" 0
 688     nick_forget $n
 689 }
 690
 691 proc msg_PRIVMSG {p c dest text} {
 692     prefix_nick
 693     if {[ischan $dest]} {
 694         recordlastseen_n $n "invoking me in $dest" 1
 695         set output $dest
 696     } else {
 697         recordlastseen_n $n "talking to me" 1
 698         set output $n
 699     }
 700     nick_case $n
 701
 702     if {[catch {
 703         regsub {^! *} $text {} text
 704         set ucmd [ta_word]
 705         set procname ucmd/[string tolower $ucmd]
 706         if {[catch { info body $procname }]} {
 707             error "unknown command; try help for help"
 708         }
 709         $procname $p $dest
 710     } rv]} {
 711         sendprivmsg $n "error: $rv"
 712     } else {
 713         manyset $rv priv_msgs pub_msgs priv_acts pub_acts
 714         foreach {td val} [list $n $priv_acts $output $pub_acts] {
 715             foreach l [split $val "\n"] {
 716                 sendaction_priority 0 $td $l
 717             }
 718         }
 719         foreach {td val} [list $n $priv_msgs $output $pub_msgs] {
 720             foreach l [split $val "\n"] {
 721                 sendprivmsg $td $l
 722             }
 723         }
 724     }
 725 }
 726
 727 proc msg_INVITE {p c n chan} {
 728     after 1000 [list dojoin [irctolower $chan]]
 729 }
 730
 731 proc grep {var predicate list} {
 732     set o {}
 733     upvar 1 $var v
 734     foreach v $list {
 735         if {[uplevel 1 [list expr $predicate]]} { lappend o $v }
 736     }
 737     return $o
 738 }
 739
 740 proc msg_353 {p c dest type chan nicklist} {
 741     global names_chans nick_onchans
 742     set lchan [irctolower $chan]
 743     upvar #0 chan_nicks($lchan) nlist
 744     lappend names_chans $lchan
 745     if {![info exists nlist]} {
 746         # We don't think we're on this channel, so ignore it !
 747         # Unfortunately, because we don't get a reply to PART,
 748         # we have to remember ourselves whether we're on a channel,
 749         # and ignore stuff if we're not, to avoid races.  Feh.
 750         return
 751     }
 752     set nlist_new {}
 753     foreach user [split $nicklist { }] {
 754         regsub {^[@+]} $user {} user
 755         if {![string length $user]} continue
 756         check_nick $user
 757         set luser [irctolower $user]
 758         upvar #0 nick_onchans($luser) oc
 759         lappend oc $lchan
 760         lappend nlist_new $luser
 761         nick_ishere $user
 762     }
 763     set nlist $nlist_new
 764 }
 765
 766 proc msg_366 {p c args} {
 767     global names_chans nick_onchans
 768     set lchan [irctolower $c]
 769     foreach luser [array names nick_onchans] {
 770         upvar #0 nick_onchans($luser) oc
 771         if {[llength names_chans] > 1} {
 772             set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc]
 773         }
 774         if {![llength $oc]} { lnick_forget $n }
 775     }
 776     unset names_chans
 777 }
 778
 779 proc ta_anymore {} {
 780     upvar 1 text text
 781     return [expr {!![string length $text]}]
 782 }
 783
 784 proc ta_nomore {} {
 785     upvar 1 text text
 786     if {[string length $text]} { error "too many parameters" }
 787 }
 788
 789 proc ta_word {} {
 790     upvar 1 text text
 791     if {![regexp {^([^  ]+) *(.*)} $text dummy firstword text]} {
 792         error "too few parameters"
 793     }
 794     return $firstword
 795 }
 796
 797 proc ta_nick {} {
 798     upvar 1 text text
 799     set v [ta_word]
 800     check_nick $v
 801     return $v
 802 }
 803
 804 proc def_ucmd {cmdname body} {
 805     proc ucmd/$cmdname {p dest} "    upvar 1 text text\n$body"
 806 }
 807
 808 proc ucmdr {priv pub args} {
 809     return -code return [concat [list $priv $pub] $args]
 810 }
 811
 812 proc loadhelp {} {
 813     global help_topics errorInfo
 814
 815     catch { unset help_topics }
 816     set f [open helpinfos r]
 817     try_except_finally {
 818         set lno 0
 819         while {[gets $f l] >= 0} {
 820             incr lno
 821             if {[regexp {^#.*} $l]} {
 822             } elseif {[regexp {^ *$} $l]} {
 823                 if {[info exists topic]} {
 824                     set help_topics($topic) [join $lines "\n"]
 825                     unset topic
 826                     unset lines
 827                 }
 828             } elseif {[regexp {^\:\:} $l]} {
 829             } elseif {[regexp {^\:([-+._0-9a-z]*)$} $l dummy newtopic]} {
 830                 if {[info exists topic]} {
 831                     error "help $newtopic while in $topic"
 832                 }
 833                 set topic $newtopic
 834                 set lines {}
 835             } elseif {[regexp {^[^:#]} $l]} {
 836                 set topic
 837                 regsub -all {([^\\])\!\$?} _$l {\1} l
 838                 regsub -all {\\(.)} $l {\1} l
 839                 regsub {^_} $l {} l
 840                 lappend lines [string trimright $l]
 841             } else {
 842                 error "eh ? $lno: $l"
 843             }
 844         }
 845         if {[info exists topic]} { error "unfinished topic $topic" }
 846     } {
 847         set errorInfo "in helpinfos line $lno\n$errorInfo"
 848     } {
 849         close $f
 850     }
 851 }
 852
 853 def_ucmd help {
 854     upvar 1 n n
 855
 856     set topic [irctolower [string trim $text]]
 857     if {[string length $topic]} {
 858         set ontopic " on `$topic'"
 859     } else {
 860         set ontopic ""
 861     }
 862     if {[set lag [out_lagged]]} {
 863         if {[ischan $dest]} { set replyto $dest } else { set replyto $n }
 864         if {$lag > 1} {
 865             sendaction_priority 1 $replyto \
 866                 "is very lagged.  Please ask for help$ontopic again later."
 867             ucmdr {} {}
 868         } else {
 869             sendaction_priority 1 $replyto \
 870                 "is lagged.  Your help$ontopic will arrive shortly ..."
 871         }
 872     }
 873
 874     upvar #0 help_topics($topic) info
 875     if {![info exists info]} { ucmdr "No help on $topic, sorry." {} }
 876     ucmdr $info {}
 877 }
 878
 879 def_ucmd ? {
 880     global help_topics
 881     ucmdr $help_topics() {}
 882 }
 883
 884 proc check_username {target} {
 885     if {
 886         [string length $target] > 8 ||
 887         [regexp {[^-0-9a-z]} $target] ||
 888         ![regexp {^[a-z]} $target]
 889     } { error "invalid username" }
 890 }
 891
 892 proc somedb__head {} {
 893     uplevel 1 {
 894         set idl [irctolower $id]
 895         upvar #0 ${nickchan}db($idl) ndbe
 896         binary scan $idl H* idh
 897         set idfn $fprefix$idh
 898         if {![info exists iddbe] && [file exists $idfn]} {
 899             set f [open $idfn r]
 900             try_except_finally { set newval [read $f] } {} { close $f }
 901             if {[llength $newval] % 2} { error "invalid length" }
 902             set iddbe $newval
 903         }
 904     }
 905 }
 906
 907 proc def_somedb {name arglist body} {
 908     foreach {nickchan fprefix} {nick users/n chan chans/c} {
 909         proc ${nickchan}db_$name $arglist \
 910             "set nickchan $nickchan; set fprefix $fprefix; $body"
 911     }
 912 }
 913
 914 def_somedb list {} {
 915     set list {}
 916     foreach path [glob -nocomplain -path $fprefix *] {
 917         binary scan $path "A[string length $fprefix]A*" afprefix thinghex
 918         if {"$afprefix" != "$fprefix"} { error "wrong prefix $path $afprefix" }
 919         lappend list [binary format H* $thinghex]
 920     }
 921     return $list
 922 }
 923
 924 proc def_somedb_id {name arglist body} {
 925     def_somedb $name [concat id $arglist] "somedb__head; $body"
 926 }
 927
 928 def_somedb_id exists {} {
 929     return [info exists iddbe]
 930 }
 931
 932 def_somedb_id delete {} {
 933     catch { unset iddbe }
 934     file delete $idfn
 935 }
 936
 937 set default_settings_nick {timeformat ks  marktime off}
 938 set default_settings_chan {
 939     autojoin 1
 940     mode *
 941     userinvite pub
 942     topicset {}
 943     topicsee {}
 944     topictell {}
 945 }
 946
 947 def_somedb_id set {args} {
 948     upvar #0 default_settings_$nickchan def
 949     if {![info exists iddbe]} { set iddbe $def }
 950     foreach {key value} [concat $iddbe $args] { set a($key) $value }
 951     set newval {}
 952     foreach {key value} [array get a] { lappend newval $key $value }
 953     set f [open $idfn.new w]
 954     try_except_finally {
 955         puts $f $newval
 956         close $f
 957         file rename -force $idfn.new $idfn
 958     } {
 959     } {
 960         catch { close $f }
 961     }
 962     set iddbe $newval
 963 }
 964
 965 def_somedb_id get {key} {
 966     upvar #0 default_settings_$nickchan def
 967     if {[info exists iddbe]} {
 968         set l [concat $iddbe $def]
 969     } else {
 970         set l $def
 971     }
 972     foreach {tkey value} $l {
 973         if {"$tkey" == "$key"} { return $value }
 974     }
 975     error "unset setting $key"
 976 }
 977
 978 proc opt {key} {
 979     global calling_nick
 980     if {[info exists calling_nick]} { set n $calling_nick } { set n {} }
 981     return [nickdb_get $n $key]
 982 }
 983
 984 proc check_notonchan {} {
 985     upvar 1 dest dest
 986     if {[ischan $dest]} { error "that command must be sent privately" }
 987 }
 988
 989 proc nick_securitycheck {strict} {
 990     upvar 1 n n
 991     if {![nickdb_exists $n]} { error "you are unknown to me, use `register'." }
 992     set wantu [nickdb_get $n username]
 993     if {![string length $wantu]} {
 994         if {$strict} {
 995             error "that feature is only available to secure users, sorry."
 996         } else {
 997             return
 998         }
 999     }
1000     set luser [irctolower $n]
1001     upvar #0 nick_username($luser) nu
1002     if {![info exists nu]} {
1003         error "nick $n is secure, you must identify yourself first."
1004     }
1005     if {"$wantu" != "$nu"} {
1006         error "you are the wrong user - the nick $n belongs to $wantu, not $nu"
1007     }
1008 }
1009
1010 proc channel_securitycheck {channel n} {
1011     # You must also call `nick_securitycheck 1'
1012     set mgrs [chandb_get $channel managers]
1013     if {[lsearch -exact [irctolower $mgrs] [irctolower $n]] < 0} {
1014         error "you are not a manager of $channel"
1015     }
1016 }
1017
1018 proc def_chancmd {name body} {
1019     proc channel/$name {} \
1020             "    upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body"
1021 }
1022
1023 proc ta_listop {findnow procvalue} {
1024     # findnow and procvalue are code fragments which will be executed
1025     # in the caller's level.  findnow should set ta_listop_ev to
1026     # the current list, and procvalue should treat ta_listop_ev as
1027     # a proposed value in the list and check and possibly modify
1028     # (canonicalise?) it.  After ta_listop, ta_listop_ev will
1029     # be the new value of the list.
1030     upvar 1 ta_listop_ev exchg
1031     upvar 1 text text
1032     set opcode [ta_word]
1033     switch -exact _$opcode {
1034         _= { }
1035         _+ - _- {
1036             uplevel 1 $findnow
1037             foreach item $exchg { set array($item) 1 }
1038         }
1039         default {
1040             error "list change opcode must be one of + - ="
1041         }
1042     }
1043     foreach exchg [split $text " "] {
1044         if {![string length $exchg]} continue
1045         uplevel 1 $procvalue
1046         if {"$opcode" != "-"} {
1047             set array($exchg) 1
1048         } else {
1049             catch { unset array($exchg) }
1050         }
1051     }
1052     set exchg [lsort [array names array]]
1053 }
1054
1055 def_chancmd manager {
1056     ta_listop {
1057         if {[chandb_exists $chan]} {
1058             set ta_listop_ev [chandb_get $chan managers]
1059         } else {
1060             set ta_listop_ev [list [irctolower $n]]
1061         }
1062     } {
1063         check_nick $ta_listop_ev
1064         set ta_listop_ev [irctolower $ta_listop_ev]
1065     }
1066     if {[llength $ta_listop_ev]} {
1067         chandb_set $chan managers $ta_listop_ev
1068         ucmdr "Managers of $chan: $ta_listop_ev" {}
1069     } else {
1070         chandb_delete $chan
1071         ucmdr {} {} "forgets about managing $chan." {}
1072     }
1073 }
1074
1075 def_chancmd autojoin {
1076     set yesno [ta_word]
1077     switch -exact [string tolower $yesno] {
1078         no { set nv 0 }
1079         yes { set nv 1 }
1080         default { error "channel autojoin must be `yes' or `no' }
1081     }
1082     chandb_set $chan autojoin $nv
1083     ucmdr [expr {$nv ? "I will join $chan when I'm restarted " : \
1084             "I won't join $chan when I'm restarted "}] {}
1085 }
1086
1087 def_chancmd userinvite {
1088     set nv [string tolower [ta_word]]
1089     switch -exact $nv {
1090         pub { set txt "!invite will work for $chan, but it won't work by /msg" }
1091         here { set txt "!invite and /msg invite will work, but only for users who are already on $chan." }
1092         all { set txt "Any user will be able to invite themselves or anyone else to $chan." }
1093         none { set txt "I will not invite anyone to $chan." }
1094         default {
1095             error "channel userinvite must be `pub', `here', `all' or `none'
1096         }
1097     }
1098     chandb_set $chan userinvite $nv
1099     ucmdr $txt {}
1100 }
1101
1102 def_chancmd topic {
1103     set what [ta_word]
1104     switch -exact $what {
1105         leave {
1106             ta_nomore
1107             chandb_set $chan topicset {}
1108             ucmdr "I won't ever change the topic of $chan." {}
1109         }
1110         set {
1111             set t [string trim $text]
1112             if {![string length $t]} {
1113                 error "you must specific the topic to set"
1114             }
1115             chandb_set $chan topicset $t
1116             ucmdr "Whenever I'm alone on $chan, I'll set the topic to $t." {}
1117         }
1118         see - tell {
1119             ta_listop {
1120                 set ta_listop_ev [chandb_get $chan topic$what]
1121             } {
1122                 if {"$ta_listop_ev" != "*"} {
1123                     if {![ischan $ta_listop_ev]} {
1124                         error "bad channel \`$ta_listop_ev' in topic $what"
1125                     }
1126                     set ta_listop_ev [irctolower $ta_listop_ev]
1127                 }
1128             }
1129             chandb_set $chan topic$what $ta_listop_ev
1130             ucmdr "Topic $what list for $chan: $ta_listop_ev" {}
1131         }
1132         default {
1133             error "unknown channel topic subcommand - see help channel"
1134         }
1135     }
1136 }
1137
1138 def_chancmd mode {
1139     set mode [ta_word]
1140     if {"$mode" != "*" && ![regexp {^(([-+][imnpst]+)+)$} $mode mode]} {
1141         error {channel mode must be * or match ([-+][imnpst]+)+}
1142     }
1143     chandb_set $chan mode $mode
1144     if {"$mode" == "*"} {
1145         ucmdr "I won't ever change the mode of $chan." {}
1146     } else {
1147         ucmdr "Whenever I'm alone on $chan, I'll set the mode to $mode." {}
1148     }
1149 }
1150
1151 def_chancmd show {
1152     if {[chandb_exists $chan]} {
1153         set l "Settings for $chan: autojoin "
1154         append l [lindex {no yes} [chandb_get $chan autojoin]]
1155         append l ", mode " [chandb_get $chan mode]
1156         append l ", userinvite " [chandb_get $chan userinvite] "."
1157         append l "\nManagers: "
1158         append l [join [chandb_get $chan managers] " "]
1159         foreach {ts sep} {see "\n" tell "  "} {
1160             set t [chandb_get $chan topic$ts]
1161             append l $sep
1162             if {[llength $t]} {
1163                 append l "Topic $ts list: $t."
1164             } else {
1165                 append l "Topic $ts list is empty."
1166             }
1167         }
1168         append l "\n"
1169         set t [chandb_get $chan topicset]
1170         if {[string length $t]} {
1171             append l "Topic to set: $t"
1172         } else {
1173             append l "I will not change the topic."
1174         }
1175         ucmdr {} $l
1176     } else {
1177         ucmdr {} "The channel $chan is not managed."
1178     }
1179 }
1180
1181 proc channelmgr_monoop {} {
1182     upvar 1 dest dest
1183     upvar 1 text text
1184     upvar 1 n n
1185     upvar 1 p p
1186     upvar 1 target target
1187     global chan_nicks
1188
1189     prefix_nick
1190
1191     if {[ischan $dest]} { set target $dest }
1192     if {[ta_anymore]} { set target [ta_word] }
1193     ta_nomore
1194     if {![info exists target]} {
1195         error "you must specify, or invoke me on, the relevant channel"
1196     }
1197     if {![info exists chan_nicks([irctolower $target])]} {
1198         error "I am not on $target."
1199     }
1200     if {![ischan $target]} { error "not a valid channel" }
1201
1202     if {![chandb_exists $target]} { error "$target is not a managed channel." }
1203     nick_securitycheck 1
1204     channel_securitycheck $target $n
1205 }
1206
1207 def_ucmd op {
1208     channelmgr_monoop
1209     sendout MODE $target +o $n
1210 }
1211
1212 def_ucmd leave {
1213     channelmgr_monoop
1214     doleave $target
1215 }
1216
1217 def_ucmd invite {
1218     global chan_nicks
1219
1220     if {[ischan $dest]} {
1221         set target $dest
1222         set onchan 1
1223     } else {
1224         set target [ta_word]
1225         set onchan 0
1226     }
1227     set ltarget [irctolower $target]
1228     if {![ischan $target]} { error "$target is not a channel." }
1229     if {![info exists chan_nicks($ltarget)]} { error "I am not on $target." }
1230     set ui [chandb_get $ltarget userinvite]
1231     if {"$ui" == "pub" && !$onchan} {
1232         error "Invitations to $target must be made with !invite."
1233     }
1234     if {"$ui" != "all"} {
1235         prefix_nick
1236         if {[lsearch -exact $chan_nicks($ltarget) [irctolower $n]] < 0} {
1237  error "Invitations to $target may only be made by a user on the channel."
1238         }
1239     }
1240     if {"$ui" == "none"} {
1241         error "Sorry, I've not been authorised to invite people to $target."
1242     }
1243     if {![ta_anymore]} {
1244         error "You have to say who to invite."
1245     }
1246     set invitees {}
1247     while {[ta_anymore]} {
1248         set invitee [ta_word]
1249         check_nick $invitee
1250         lappend invitees $invitee
1251     }
1252     foreach invitee $invitees {
1253         sendout INVITE $invitee $ltarget
1254     }
1255     set who [lindex $invitees 0]
1256     switch -exact llength $invitees {
1257         0 { error "zero invitees" }
1258         1 { }
1259         2 { append who " and [lindex $invitees 1]" }
1260         * {
1261             set who [join [lreplace $invitees end end] ", "]
1262             append who " and [lindex $invitees [llength $invitees]]"
1263         }
1264     }
1265     ucmdr {} "invites $who to $target."
1266 }
1267
1268 def_ucmd channel {
1269     if {[ischan $dest]} { set target $dest }
1270     if {![ta_anymore]} {
1271         set subcmd show
1272     } else {
1273         set subcmd [ta_word]
1274     }
1275     if {[ischan $subcmd]} {
1276         set target $subcmd
1277         if {![ta_anymore]} {
1278             set subcmd show
1279         } else {
1280             set subcmd [ta_word]
1281         }
1282     }
1283     if {![info exists target]} { error "privately, you must specify a channel" }
1284     set procname channel/$subcmd
1285     if {"$subcmd" != "show"} {
1286         if {[catch { info body $procname }]} { error "unknown channel setting $subcmd" }
1287         prefix_nick
1288         nick_securitycheck 1
1289         if {[chandb_exists $target]} {
1290             channel_securitycheck $target $n
1291         } else {
1292             upvar #0 chan_initialop([irctolower $target]) io
1293             upvar #0 nick_unique([irctolower $n]) u
1294             if {![info exists io]} { error "$target is not a managed channel" }
1295             if {"$io" != "$u"} { error "you are not the interim manager of $target" }
1296             if {"$subcmd" != "manager"} { error "use `channel manager' first" }
1297         }
1298     }
1299     channel/$subcmd
1300 }
1301
1302 def_ucmd who {
1303     if {[ta_anymore]} {
1304         set target [ta_word]; ta_nomore
1305         set myself 1
1306     } else {
1307         prefix_nick
1308         set target $n
1309         set myself [expr {"$target" != "$n"}]
1310     }
1311     set ltarget [irctolower $target]
1312     upvar #0 nick_case($ltarget) ctarget
1313     set nshow $target
1314     if {[info exists ctarget]} {
1315         upvar #0 nick_onchans($ltarget) oc
1316         upvar #0 nick_username($ltarget) nu
1317         if {[info exists oc]} { set nshow $ctarget }
1318     }
1319     if {![nickdb_exists $ltarget]} {
1320         set ol "$nshow is not a registered nick."
1321     } elseif {[string length [set username [nickdb_get $target username]]]} {
1322         set ol "The nick $nshow belongs to the user $username."
1323     } else {
1324         set ol "The nick $nshow is registered (but not to a username)."
1325     }
1326     if {![info exists ctarget] || ![info exists oc]} {
1327         if {$myself} {
1328             append ol "\nI can't see $nshow on anywhere."
1329         } else {
1330             append ol "\nYou aren't on any channels with me."
1331         }
1332     } elseif {![info exists nu]} {
1333         append ol "\n$nshow has not identified themselves."
1334     } elseif {![info exists username]} {
1335         append ol "\n$nshow has identified themselves as the user $nu."
1336     } elseif {"$nu" != "$username"} {
1337         append ol "\nHowever, $nshow is being used by the user $nu."
1338     } else {
1339         append ol "\n$nshow has identified themselves to me."
1340     }
1341     ucmdr {} $ol
1342 }
1343
1344 def_ucmd register {
1345     prefix_nick
1346     check_notonchan
1347     set old [nickdb_exists $n]
1348     if {$old} { nick_securitycheck 0 }
1349     set luser [irctolower $n]
1350     switch -exact [string tolower [string trim $text]] {
1351         {} {
1352             upvar #0 nick_username($luser) nu
1353             if {![info exists nu]} {
1354                 ucmdr {} \
1355  "You must identify yourself before using `register'.  See `help identify', or use `register insecure'."
1356             }
1357             nickdb_set $n username $nu
1358             ucmdr {} {} "makes a note of your username." {}
1359         }
1360         delete {
1361             nickdb_delete $n
1362             ucmdr {} {} "forgets your nickname." {}
1363         }
1364         insecure {
1365             nickdb_set $n username {}
1366             if {$old} {
1367                 ucmdr {} "Security is now disabled for your nickname !"
1368             } else {
1369                 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."
1370             }
1371         }
1372     }
1373 }
1374
1375 proc timeformat_desc {tf} {
1376     switch -exact $tf {
1377         ks { return "Times will be displayed in seconds or kiloseconds." }
1378         hms { return "Times will be displayed in hours, minutes, etc." }
1379         default { error "invalid timeformat: $v" }
1380     }
1381 }
1382
1383 proc def_setting {opt show_body set_body} {
1384     proc set_show/$opt {} "
1385         upvar 1 n n
1386         set opt $opt
1387         $show_body"
1388     if {![string length $set_body]} return
1389     proc set_set/$opt {} "
1390         upvar 1 n n
1391         upvar 1 text text
1392         set opt $opt
1393         $set_body"
1394 }
1395
1396 def_setting timeformat {
1397     set tf [nickdb_get $n timeformat]
1398     return "$tf: [timeformat_desc $tf]"
1399 } {
1400     set tf [string tolower [ta_word]]
1401     ta_nomore
1402     set desc [timeformat_desc $tf]
1403     nickdb_set $n timeformat $tf
1404     ucmdr {} $desc
1405 }
1406
1407 proc marktime_desc {mt} {
1408     if {"$mt" == "off"} {
1409         return "I will not send you periodic messages."
1410     } elseif {"$mt" == "once"} {
1411         return "I will send you one informational message when I see you."
1412     } else {
1413         return "I'll send you a message every [showintervalsecs $mt 0]."
1414     }
1415 }
1416
1417 def_setting marktime {
1418     set mt [nickdb_get $n marktime]
1419     set p $mt
1420     if {[string match {[0-9]*} $mt]} { append p s }
1421     append p ": "
1422     append p [marktime_desc $mt]
1423     return $p
1424 } {
1425     global marktime_min
1426     set mt [string tolower [ta_word]]
1427     ta_nomore
1428
1429     if {"$mt" == "off" || "$mt" == "once"} {
1430     } elseif {[regexp {^([0-9]+)([a-z]+)$} $mt dummy value unit]} {
1431         switch -exact $unit {
1432             s { set u 1 }
1433             ks { set u 1000 }
1434             m { set u 60 }
1435             h { set u 3600 }
1436             default { error "unknown unit of time $unit" }
1437         }
1438         if {$value > 86400*21/$u} { error "marktime interval too large" }
1439         set mt [expr {$value*$u}]
1440         if {$mt < $marktime_min} { error "marktime interval too small" }
1441     } else {
1442         error "invalid syntax for marktime"
1443     }
1444     nickdb_set $n marktime $mt
1445     lnick_marktime_start [irctolower $n] "So:" 500
1446     ucmdr {} [marktime_desc $mt]
1447 }
1448
1449 def_setting security {
1450     set s [nickdb_get $n username]
1451     if {[string length $s]} {
1452         return "Your nick, $n, is controlled by the user $s."
1453     } else {
1454         return "Your nick, $n, is not secure."
1455     }
1456 } {}
1457
1458 def_ucmd set {
1459     prefix_nick
1460     check_notonchan
1461     if {![nickdb_exists $n]} {
1462         ucmdr {} "You are unknown to me and so have no settings.  (Use `register'.)"
1463     }
1464     if {![ta_anymore]} {
1465         set ol {}
1466         foreach proc [lsort [info procs]] {
1467             if {![regexp {^set_show/(.*)$} $proc dummy opt]} continue
1468             lappend ol [format "%-10s %s" $opt [set_show/$opt]]
1469         }
1470         ucmdr {} [join $ol "\n"]
1471     } else {
1472         set opt [ta_word]
1473         if {[catch { info body set_show/$opt }]} {
1474             error "no setting $opt"
1475         }
1476         if {![ta_anymore]} {
1477             ucmdr {} "$opt [set_show/$opt]"
1478         } else {
1479             nick_securitycheck 0
1480             if {[catch { info body set_set/$opt }]} {
1481                 error "setting $opt cannot be set with `set'"
1482             }
1483             set_set/$opt
1484         }
1485     }
1486 }
1487
1488 def_ucmd identpass {
1489     set username [ta_word]
1490     set passmd5 [md5sum "[ta_word]\n"]
1491     ta_nomore
1492     prefix_nick
1493     check_notonchan
1494     set luser [irctolower $n]
1495     upvar #0 nick_onchans($luser) onchans
1496     if {![info exists onchans] || ![llength $onchans]} {
1497         ucmdr "You must be on a channel with me to identify yourself." {}
1498     }
1499     check_username $username
1500     exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \
1501             irc-identpass $n
1502     upvar #0 nick_username($luser) rec_username
1503     set rec_username $username
1504     ucmdr "Pleased to see you, $username." {}
1505 }
1506
1507 def_ucmd summon {
1508     set target [ta_word]
1509     ta_nomore
1510     check_username $target
1511     prefix_nick
1512
1513     upvar #0 lastsummon($target) ls
1514     set now [clock seconds]
1515     if {[info exists ls]} {
1516         set interval [expr {$now - $ls}]
1517         if {$interval < 30} {
1518             ucmdr {} \
1519  "Please be patient; $target was summoned only [showinterval $interval]."
1520         }
1521     }
1522     regsub {^[^!]*!} $p {} path
1523     if {[catch {
1524         exec userv --timeout 3 $target irc-summon $n $path \
1525                 [expr {[ischan $dest] ? "$dest" : ""}] \
1526                 < /dev/null
1527     } rv]} {
1528         regsub -all "\n" $rv { / } rv
1529         error $rv
1530     }
1531     if {[regexp {^problem (.*)} $rv dummy problem]} {
1532         ucmdr {} "The user `$target' $problem."
1533     } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} {
1534         set idletime [expr {$now - $idlesince}]
1535         set ls $now
1536         ucmdr {} {} {} "invites $target ($tty[expr {
1537             $idletime > 10 ? ", idle for [showintervalsecs $idletime 0]" : ""
1538         }]) to [expr {
1539             [ischan $dest] ? "join us here" : "talk to you"
1540         }]."
1541     } else {
1542         error "unexpected response from userv service: $rv"
1543     }
1544 }
1545
1546 proc md5sum {value} { exec md5sum << $value }
1547
1548 def_ucmd seen {
1549     global lastseen nick
1550     prefix_nick
1551     set ncase [ta_nick]
1552     set nlower [irctolower $ncase]
1553     ta_nomore
1554     set now [clock seconds]
1555     if {"$nlower" == "[irctolower $nick]"} {
1556         error "I am not self-aware."
1557     } elseif {![info exists lastseen($nlower)]} {
1558         set rstr "I've never seen $ncase."
1559     } else {
1560         manyset $lastseen($nlower) realnick time what
1561         set howlong [expr {$now - $time}]
1562         set string [showinterval $howlong]
1563         set rstr "I last saw $realnick $string, $what."
1564     }
1565     if {[ischan $dest]} {
1566         set where $dest
1567     } else {
1568         set where {}
1569     }
1570     upvar #0 lookedfor($nlower) lf
1571     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
1572     set lf [list [list $now $n $where]]
1573     foreach v $oldvalue {
1574         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
1575         lappend lf $v
1576     }
1577     ucmdr {} $rstr
1578 }
1579
1580 proc lnick_marktime_cancel {luser} {
1581     upvar #0 nick_markid($luser) mi
1582     if {![info exists mi]} return
1583     catch { after cancel $mi }
1584     catch { unset mi }
1585 }
1586
1587 proc lnick_marktime_doafter {luser why ms} {
1588     lnick_marktime_cancel $luser
1589     upvar #0 nick_markid($luser) mi
1590     set mi [after $ms [list lnick_marktime_now $luser $why]]
1591 }
1592
1593 proc lnick_marktime_reset {luser} {
1594     set mt [nickdb_get $luser marktime]
1595     if {"$mt" == "off" || "$mt" == "once"} return
1596     lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}]
1597 }
1598
1599 proc lnick_marktime_start {luser why ms} {
1600     set mt [nickdb_get $luser marktime]
1601     if {"$mt" == "off"} {
1602         lnick_marktime_cancel $luser
1603     } else {
1604         lnick_marktime_doafter $luser $why $ms
1605     }
1606 }
1607
1608 proc lnick_marktime_now {luser why} {
1609     upvar #0 nick_onchans($luser) oc
1610     global calling_nick
1611     set calling_nick $luser
1612     sendprivmsg $luser [lnick_pingstring $why $oc ""]
1613     lnick_marktime_reset $luser
1614 }
1615
1616 proc lnick_pingstring {why oc apstring} {
1617     global nick_onchans
1618     catch { exec uptime } uptime
1619     set nnicks [llength [array names nick_onchans]]
1620     if {[regexp \
1621  {^ *([0-9:apm]+) +up.*, +(\d+) users, +load average: +([0-9., ]+) *$} \
1622             $uptime dummy time users load]} {
1623         regsub -all , $load {} load
1624         set uptime "$time  $nnicks/$users  $load"
1625     } else {
1626         append uptime ", $nnicks nicks"
1627     }
1628     if {[llength $oc]} {
1629         set best_la 0
1630         set activity quiet
1631         foreach ch $oc {
1632             upvar #0 chan_lastactivity($ch) la
1633             if {![info exists la]} continue
1634             if {$la <= $best_la} continue
1635             set since [showintervalsecs [expr {[clock seconds]-$la}] 1]
1636             set activity "$ch $since"
1637             set best_la $la
1638         }
1639     } else {
1640         set activity unseen
1641     }
1642     set str $why
1643     append str "  " $uptime "  " $activity
1644     if {[string length $apstring]} { append str "  " $apstring }
1645     return $str
1646 }
1647
1648 def_ucmd ping {
1649     if {[ischan $dest]} {
1650         set oc [irctolower $dest]
1651     } else {
1652         global nick_onchans
1653         prefix_nick
1654         set ln [irctolower $n]
1655         if {[info exists nick_onchans($ln)]} {
1656             set oc $nick_onchans($ln)
1657         } else {
1658             set oc {}
1659         }
1660         if {[llength $oc]} { lnick_marktime_reset $ln }
1661     }
1662     ucmdr {} [lnick_pingstring "Pong!" $oc $text]
1663 }
1664
1665 proc ensure_globalsecret {} {
1666     global globalsecret
1667
1668     if {[info exists globalsecret]} return
1669     set gsfile [open /dev/urandom r]
1670     fconfigure $gsfile -translation binary
1671     set globalsecret [read $gsfile 32]
1672     binary scan $globalsecret H* globalsecret
1673     close $gsfile
1674     unset gsfile
1675 }
1676
1677 proc ensure_outqueue {} {
1678     out__vars
1679     if {[info exists out_queue]} return
1680     set out_creditms 0
1681     set out_creditat [clock seconds]
1682     set out_queue {}
1683     set out_lag_reported 0
1684     set out_lag_reportwhen $out_creditat
1685 }
1686
1687 proc fail {msg} {
1688     logerror "failing: $msg"
1689     exit 1
1690 }
1691
1692 proc ensure_connecting {} {
1693     global sock ownfullname host port nick socketargs
1694     global musthaveping_ms musthaveping_after
1695
1696     if {[info exists sock]} return
1697     set sock [eval socket $socketargs [list $host $port]]
1698     fconfigure $sock -buffering line
1699     fconfigure $sock -translation crlf
1700
1701     sendout USER blight 0 * $ownfullname
1702     sendout NICK $nick
1703     fileevent $sock readable onread
1704
1705     set musthaveping_after [after $musthaveping_ms \
1706             {fail "no ping within timeout"}]
1707 }
1708
1709 proc connected {} {
1710     global musthaveping_after
1711
1712     after cancel $musthaveping_after
1713     unset musthaveping_after
1714
1715     foreach chan [chandb_list] {
1716         if {[chandb_get $chan autojoin]} { dojoin $chan }
1717     }
1718 }
1719
1720 ensure_globalsecret
1721 ensure_outqueue
1722 loadhelp
1723 ensure_connecting