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

   1 # Actual IRC bot code
   2
   3 set helpfile helpinfos
   4
   5 source irccore.tcl
   6 source parsecmd.tcl
   7 source stdhelp.tcl
   8
   9 defset marktime_min 300
  10 defset marktime_join_startdelay 5000
  11
  12 proc privmsg_unlogged {prefix ischan params} {
  13     if {!$ischan ||
  14         [regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} {
  15         return 0
  16     }
  17     # on-channel message, ignore
  18     set chan [lindex $params 0]
  19     upvar #0 chan_lastactivity([irctolower $chan]) la
  20     set la [clock seconds]
  21     catch_logged { recordlastseen_p $prefix "talking on $chan" 2 }
  22     return 1
  23 }
  24
  25 proc showintervalsecs {howlong abbrev} {
  26     return [showintervalsecs/[opt timeformat] $howlong $abbrev]
  27 }
  28
  29 proc showintervalsecs/ks {howlong abbrev} {
  30     if {$howlong < 1000} {
  31         return "${howlong}s"
  32     } else {
  33         if {$howlong < 1000000} {
  34             set pfx k
  35             set scale 1000
  36         } else {
  37             set pfx M
  38             set scale 1000000
  39         }
  40         set value [expr "$howlong.0 / $scale"]
  41         foreach {min format} {100 %.0f 10 %.1f 1 %.2f} {
  42             if {$value < $min} continue
  43             return [format "$format${pfx}s" $value]
  44         }
  45     }
  46 }
  47
  48 proc format_qty {qty unit abbrev} {
  49     set o $qty
  50     if {$abbrev} {
  51         append o [string range $unit 0 0]
  52     } else {
  53         append o " "
  54         append o $unit
  55         if {$qty != 1} { append o s }
  56     }
  57     return $o
  58 }
  59
  60 proc showintervalsecs/hms {qty abbrev} {
  61     set ul {second 60 minute 60 hour 24 day 7 week}
  62     set remainv 0
  63     while {[llength $ul] > 1 && $qty >= [set uv [lindex $ul 1]]} {
  64         set remainu [lindex $ul 0]
  65         set remainv [expr {$qty % $uv}]
  66         set qty [expr {($qty-$remainv)/$uv}]
  67         set ul [lreplace $ul 0 1]
  68     }
  69     set o [format_qty $qty [lindex $ul 0] $abbrev]
  70     if {$remainv} {
  71         if {!$abbrev} { append o " " }
  72         append o [format_qty $remainv $remainu $abbrev]
  73     }
  74     return $o
  75 }
  76
  77 proc showinterval {howlong} {
  78     if {$howlong <= 0} {
  79         return {just now}
  80     } else {
  81         return "[showintervalsecs $howlong 0] ago"
  82     }
  83 }
  84
  85 proc showtime {when} {
  86     return [showinterval [expr {[clock seconds] - $when}]]
  87 }
  88
  89 proc parse_interval {specified min} {
  90     if {![regexp {^([0-9]+)([a-z]+)$} $specified dummy value unit]} {
  91         error "invalid syntax for interval"
  92     }
  93     switch -exact $unit {
  94         s { set u 1 }
  95         ks { set u 1000 }
  96         m { set u 60 }
  97         h { set u 3600 }
  98         default { error "unknown unit of time $unit" }
  99     }
 100     if {$value > 86400*21/$u} { error "interval too large" }
 101     set result [expr {$value*$u}]
 102     if {$result < $min} { error "interval too small (<${min}s)" }
 103     return $result
 104 }
 105
 106 proc def_msgproc {name argl body} {
 107     proc msg_$name "varbase $argl" "\
 108     upvar #0 msg/\$varbase/dest d\n\
 109     upvar #0 msg/\$varbase/str s\n\
 110     upvar #0 msg/\$varbase/accum a\n\
 111 $body"
 112 }
 113
 114 def_msgproc begin {dest str} {
 115     set d $dest
 116     set s $str
 117     set a {}
 118 }
 119
 120 def_msgproc append {str} {
 121     set ns "$s$str"
 122     if {[string length $s] && [string length $ns] > 65} {
 123         msg__sendout $varbase
 124         set s " [string trimleft $str]"
 125     } else {
 126         set s $ns
 127     }
 128 }
 129
 130 def_msgproc finish {} {
 131     msg__sendout $varbase
 132     unset s
 133     unset d
 134     return $a
 135 }
 136
 137 def_msgproc _sendout {} {
 138     lappend a [string trimright $s]
 139     set s {}
 140 }
 141
 142 proc looking_whenwhere {when where} {
 143     set str [showtime [expr {$when-1}]]
 144     if {[string length $where]} { append str " on $where" }
 145     return $str
 146 }
 147
 148 proc tell_getcstate {} {
 149     # uses nl from caller's context
 150     # imports telling (as the nick_telling) and u
 151     # sets stt, telling_when
 152     uplevel 1 {
 153         upvar #0 nick_telling($nl) telling
 154         upvar #0 nick_unique($nl) u
 155
 156         if {[info exists telling]} {
 157             manyset $telling u_last stt telling_when
 158             if {![info exists u] || "$u_last" != "$u"} {
 159                 set stt undelivered
 160             }
 161         } else {
 162             set stt undelivered
 163             set telling_when 0
 164         }
 165     }
 166 }
 167
 168 proc tell_event {nl event} {
 169     # For `act' we *haven't* yet done the 750ms delay; we implement
 170     # that here.  Also, here we turn `talk' into `talk' now and `act'
 171     # later.  We also support the psuedo-event `none'.  The del msg
 172     # and new msg events are handled by the command procedures, not here.
 173     global calling_nick
 174     if {[info exists calling_nick]} { set save $calling_nick }
 175     set r DELAYED
 176     switch -exact $event {
 177         none { }
 178         talk {
 179             tell_event_core $nl talk
 180             tell_event $nl act
 181         }
 182         act {
 183             after 750 [list tell_event_core $nl $event]
 184         }
 185         ident - msgsarrive {
 186             tell_event_core $nl $event
 187         }
 188         tellme {
 189             set r [tell_event_core $nl TELLME]
 190         }
 191         default {
 192             error "tell_event $nl $event"
 193         }
 194     }
 195     if {[info exists save]} { set calling_nick $save }
 196     return $r
 197 }
 198
 199 proc tell_event_core {nl event} {
 200     global tell_event_teventi errorInfo
 201     set tell_event_teventi "*$event* $nl"
 202     if {[catch {
 203         tell_event_core1 $nl $event
 204     } emsg]} {
 205         log_intern "tell event error" "$emsg >$errorInfo<"
 206         set emsg ERROR
 207     } else {
 208         log_intern "tell event" "done $tell_event_teventi $emsg"
 209     }
 210     return $emsg
 211 }
 212
 213 proc tell_event_core1 {nl event} {
 214     # event is `talk', `act', `ident', `msgsarrive' or `TELLME'
 215     # When user talks we actually get talk now and act later
 216     global calling_nick
 217     set calling_nick $nl
 218     set iml [msgsdb_get $nl inbound]
 219     if {![llength $iml]} { return nomsgs }
 220
 221     set now [clock seconds]
 222     tell_getcstate
 223     set ago [expr {$now - $telling_when}]
 224
 225     # Now we have the components of a telling state
 226     #   u     - nick_unique (unset if not visible)
 227     #   stt   - state: undelivered, mentioned, passede
 228     #   ago   - how long ago since we did anything
 229
 230     # We compute an evstate to dispatch on as follows:
 231
 232     # evstate is string of letters
 233     #   current state
 234     #      u   UNDELIVERED (MESSAGES)
 235     #      m   MENTIONED
 236     #      p   PASSED
 237     #   event
 238     #      t   talk
 239     #      a   act
 240     #      i   ident
 241     #      m   msgsarrive
 242     #      T   tellme (user command)
 243     #   security level and timing
 244     #      ii  Insecure
 245     #      ss  Secure and soon (before interval)
 246     #      sl  Secure and late (after interval)
 247     #   current identification
 248     #      i   Identified
 249     #      u   Unidentified
 250     #   reliability and timing
 251     #      uu  Unreliable
 252     #      rv  Remind, very soon (before within-interval)
 253     #      rs  Remind, soon (between)
 254     #      rl  Remind, late (after every-interval)
 255     #      ps  Pester, soon (before interval)
 256     #      pl  Pester, late (after interval)
 257
 258     set evstate {}
 259
 260     append evstate [string range $stt 0 0]
 261     append evstate [string range $event 0 0]
 262
 263     manyset [nickdb_get_sec_effective $nl] sec secwhen
 264     switch -exact $sec {
 265         insecure { append evstate ii }
 266         secure { append evstate [expr {$ago<$secwhen ? "ss" : "sl"}] }
 267         default { append evstate "#$sec#" }
 268     }
 269
 270     upvar #0 nick_username($nl) nu
 271     if {[info exists nu] && "$nu" == "[nickdb_get_username $nl]"} {
 272         append evstate i
 273     } else {
 274         append evstate u
 275     }
 276
 277     manyset [nickdb_get $nl tellrel] rel relint relwithin
 278     switch -exact $rel {
 279         unreliable { append evstate uu }
 280         remind { append evstate [expr {
 281             $ago<$relwithin ? "rv" : $ago<$relint ? "rs" : "rl"
 282         }]}
 283         pester { append evstate [expr {$ago<$relint ? "ps" : "pl"}] }
 284         default { append evstate "#$rel#" }
 285     }
 286
 287     global tell_event_teventi
 288     set tell_event_teventi "$evstate $ago $nl"
 289     switch -glob $evstate {
 290         pt???rv {
 291             # consider delivered:
 292             #  (very recently passed, and the user talks)
 293             tell_delete_msgs {} $nl
 294             return delivered
 295         }
 296         pm????? {
 297             # oops, messages passed are now out of date
 298             catch_restoreei { unset telling }
 299             return reset
 300         }
 301         ?m????? {
 302             # ignore new msgs if we haven't passed yet
 303             return ignorenew
 304         }
 305         ut????? - mt????? -
 306         pt???uu - pt???rs - pt???rl - pt???p? {
 307             # ignore (any other `talk's) - act handles these
 308             return ignoretalk
 309         }
 310         ui????? -
 311         uaii?uu - uaii??l - uas?i?l -
 312         mi????? - pa????l -
 313         ?Tii??? - ?Ts?i?? {
 314             # pass and then stuff
 315             if {[llength $iml] == 3} {
 316                 manyset $iml sender sentwhen msg
 317                 sendprivmsg $nl \
 318  "$sender asked me [showinterval [expr {$now-$sentwhen}]]\
 319  to tell you: $msg"
 320             } else {
 321                 sendprivmsg $nl \
 322  "I have [expr {[llength $iml]/3}] messages for you:"
 323                 while {[llength $iml] >= 3} {
 324                     manyset [lrange $iml 0 2] sender sentwhen msg
 325                     set iml [lrange $iml 3 end]
 326                     sendprivmsg $nl \
 327  " [showintervalsecs [expr {$now-$sentwhen}] 1] <$sender> $msg"
 328                 }
 329             }
 330             if {"$rel" == "unreliable"} {
 331                 tell_delete_msgs {} $nl
 332                 return toldunreliable
 333             }
 334             set stt passed
 335             set re passed
 336         }
 337         uaslu?? {
 338             sendprivmsg $nl {You have messages (so identify yourself please).}
 339             set stt mentioned
 340             set re mentioned
 341         }
 342         ?Ts?u?? {
 343             sendprivmsg $nl {You must identify yourself to see your messages.}
 344             return ignoreuitm
 345         }
 346         masl??? {
 347             sendprivmsg $nl {Don't forget about your messages.}
 348             return remind
 349         }
 350         pi????? {
 351             return ignorepi
 352         }
 353         mass??? - pa????v - pa????s -
 354         uaii??v - uaii??s -
 355         uas?i?v - uas?i?s -
 356         uassu?? {
 357             # too soon
 358             return ignoresoon
 359         }
 360         * {
 361             error "tell_event_core nl=$nl evstate=$evstate ?"
 362         }
 363     }
 364     if {![info exists u]} {
 365         set telling [list {} undelivered $now]
 366     } else {
 367         set telling [list $u $stt $now]
 368     }
 369     return $re
 370 }
 371
 372 proc recordlastseen_n {n how here} {
 373     # here is:
 374     #   0 - nick was seen leaving (or changing to another nicks or some such)
 375     #   1 - nick was seen doing something else
 376     #   2 - nick was seen talking on channel
 377     global lastseen lookedfor
 378     set nl [irctolower $n]
 379     set now [clock seconds]
 380     set lastseen($nl) [list $n $now $how]
 381
 382     if {!$here} return
 383
 384     tell_event $nl [lindex {none act talk} $here]
 385
 386     upvar #0 lookedfor($nl) lf
 387     if {[info exists lf]} {
 388         switch -exact [llength $lf] {
 389             0 {
 390                 set ml {}
 391             }
 392             1 {
 393                 manyset [lindex $lf 0] when who where
 394                 set ml [list \
 395  "FYI, $who was looking for you [looking_whenwhere $when $where]."]
 396             }
 397             default {
 398                 msg_begin tosend $n "FYI, people have been looking for you:"
 399                 set i 0
 400                 set fin ""
 401                 foreach e $lf {
 402                     incr i
 403                     if {$i == 1} {
 404                         msg_append tosend " "
 405                     } elseif {$i == [llength $lf]} {
 406                         msg_append tosend " and "
 407                         set fin .
 408                     } else {
 409                         msg_append tosend ", "
 410                     }
 411                     manyset $e when who where
 412                     msg_append tosend \
 413                             "$who ([looking_whenwhere $when $where])$fin"
 414                 }
 415                 set ml [msg_finish tosend]
 416             }
 417         }
 418         unset lf
 419         msendprivmsg_delayed 1000 $n $ml
 420     }
 421 }
 422
 423 proc note_topic {showoff whoby topic} {
 424     set msg "FYI, $whoby has changed the topic on $showoff"
 425     if {[string length $topic] < 160} {
 426         append msg " to $topic"
 427     } else {
 428         append msg " but it is too long to reproduce here !"
 429     }
 430     set showoff [irctolower $showoff]
 431     set tell [chandb_get $showoff topictell]
 432     if {[lsearch -exact $tell *] >= 0} {
 433         set tryspies [chandb_list]
 434     } else {
 435         set tryspies $tell
 436     }
 437     foreach spy $tryspies {
 438         set see [chandb_get $spy topicsee]
 439         if {[lsearch -exact $see $showoff] >= 0 || \
 440                 ([lsearch -exact $see *] >= 0 && \
 441                 [lsearch -exact $tell $spy] >= 0)} {
 442             sendprivmsg $spy $msg
 443         }
 444     }
 445 }
 446
 447 proc recordlastseen_p {p how here} {
 448     prefix_nick
 449     recordlastseen_n $n $how $here
 450 }
 451
 452 proc chanmode_arg {} {
 453     upvar 2 args cm_args
 454     set rv [lindex $cm_args 0]
 455     set cm_args [lreplace cm_args 0 0]
 456     return $rv
 457 }
 458
 459 proc chanmode_o1 {m g p chan} {
 460     global nick chan_initialop
 461     prefix_nick
 462     set who [chanmode_arg]
 463     recordlastseen_n $n "being nice to $who" 1
 464     if {"[irctolower $who]" == "[irctolower $nick]"} {
 465         set nlower [irctolower $n]
 466         upvar #0 nick_unique($nlower) u
 467         if {[chandb_exists $chan]} {
 468             sendprivmsg $n Thanks.
 469         } elseif {![info exists u]} {
 470             sendprivmsg $n {Op me while not on the channel, why don't you ?}
 471         } else {
 472             set chan_initialop([irctolower $chan]) $u
 473             sendprivmsg $n \
 474  "Thanks.  You can use `channel manager ...' to register this channel."
 475             if {![string length [nickdb_get_username $n username]]} {
 476                 sendprivmsg $n \
 477  "(But to do that you must register your nick securely first.)"
 478             }
 479         }
 480     }
 481 }
 482
 483 proc chanmode_o0 {m g p chan} {
 484     global nick chandeop
 485     prefix_nick
 486     set who [chanmode_arg]
 487     recordlastseen_p $p "being mean to $who" 1
 488     if {"[irctolower $who]" == "[irctolower $nick]"} {
 489         set chandeop($chan) [list [clock seconds] $p]
 490     }
 491 }
 492
 493 proc msg_MODE {p c dest modelist args} {
 494     if {![ischan $dest]} return
 495     if {[regexp {^\-(.+)$} $modelist dummy modelist]} {
 496         set give 0
 497     } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} {
 498         set give 1
 499     } else {
 500         error "invalid modelist"
 501     }
 502     foreach m [split $modelist] {
 503         set procname chanmode_$m$give
 504         if {[catch { info body $procname }]} {
 505             recordlastseen_p $p "fiddling with $dest" 1
 506         } else {
 507             $procname $m $give  $p $dest
 508         }
 509     }
 510 }
 511
 512 proc leaving {lchan} {
 513     foreach luser [array names nick_onchans] {
 514         upvar #0 nick_onchans($luser) oc
 515         set oc [grep tc {"$tc" != "$lchan"} $oc]
 516     }
 517     upvar #0 chan_nicks($lchan) nlist
 518     unset nlist
 519     upvar #0 chan_lastactivity($lchan) la
 520     catch { unset la }
 521 }
 522
 523 proc doleave {lchan} {
 524     sendout PART $lchan
 525     leaving $lchan
 526 }
 527
 528 proc dojoin {lchan} {
 529     global chan_nicks
 530     sendout JOIN $lchan
 531     set chan_nicks($lchan) {}
 532 }
 533
 534 proc check_justme {lchan} {
 535     global nick
 536     upvar #0 chan_nicks($lchan) nlist
 537     if {[llength $nlist] != 1} return
 538     if {"[lindex $nlist 0]" != "[irctolower $nick]"} return
 539     if {[chandb_exists $lchan]} {
 540         set mode [chandb_get $lchan mode]
 541         if {"$mode" != "*"} {
 542             sendout MODE $lchan $mode
 543         }
 544         set topic [chandb_get $lchan topicset]
 545         if {[string length $topic]} {
 546             sendout TOPIC $lchan $topic
 547         }
 548     } else {
 549         doleave $lchan
 550     }
 551 }
 552
 553 proc process_kickpart {chan user} {
 554     global nick
 555     check_nick $user
 556     set luser [irctolower $user]
 557     set lchan [irctolower $chan]
 558     if {![ischan $chan]} { error "not a channel" }
 559     if {"$luser" == "[irctolower $nick]"} {
 560         leaving $lchan
 561     } else {
 562         upvar #0 nick_onchans($luser) oc
 563         upvar #0 chan_nicks($lchan) nlist
 564         set oc [grep tc {"$tc" != "$lchan"} $oc]
 565         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 566         nick_case $user
 567         if {![llength $oc]} {
 568             nick_forget $luser
 569         } else {
 570             check_justme $lchan
 571         }
 572     }
 573 }
 574
 575 proc msg_TOPIC {p c dest topic} {
 576     prefix_nick
 577     if {![ischan $dest]} return
 578     recordlastseen_n $n "changing the topic on $dest" 1
 579     note_topic [irctolower $dest] $n $topic
 580 }
 581
 582 proc msg_KICK {p c chans users comment} {
 583     set chans [split $chans ,]
 584     set users [split $users ,]
 585     if {[llength $chans] > 1} {
 586         foreach chan $chans user $users { process_kickpart $chan $user }
 587     } else {
 588         foreach user $users { process_kickpart [lindex $chans 0] $user }
 589     }
 590 }
 591
 592 proc msg_KILL {p c user why} {
 593     nick_forget $user
 594 }
 595
 596 set nick_counter 0
 597 set nick_arys {onchans username unique}
 598 # nick_onchans($luser) -> [list ... $lchan ...]
 599 # nick_username($luser) -> <securely known local username>
 600 # nick_unique($luser) -> <includes-counter>
 601 # nick_case($luser) -> $user  (valid even if no longer visible)
 602 # nick_markid($luser) -> <after id for marktime>
 603 # nick_telling($luser) -> <unique> mentioned|passed <when>
 604
 605 # chan_nicks($lchan) -> [list ... $luser ...]
 606 # chan_lastactivity($lchan) -> [clock seconds]
 607
 608 proc lnick_forget {luser} {
 609     global nick_arys chan_nicks
 610     lnick_marktime_cancel $luser
 611     foreach ary $nick_arys {
 612         upvar #0 nick_${ary}($luser) av
 613         catch { unset av }
 614     }
 615     foreach lch [array names chan_nicks] {
 616         upvar #0 chan_nicks($lch) nlist
 617         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 618         check_justme $lch
 619     }
 620 }
 621
 622 proc nick_forget {user} {
 623     global nick_arys chan_nicks
 624     lnick_forget [irctolower $user]
 625     nick_case $user
 626 }
 627
 628 proc nick_case {user} {
 629     global nick_case
 630     set nick_case([irctolower $user]) $user
 631 }
 632
 633 proc msg_NICK {p c newnick} {
 634     global nick_arys nick_case calling_nick
 635     prefix_nick
 636     recordlastseen_n $n "changing nicks to $newnick" 0
 637     set calling_nick $newnick
 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 1
 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     nick_ishere $n
 668     recordlastseen_n $n "joining $chan" 1
 669     set nl [irctolower $n]
 670     set lchan [irctolower $chan]
 671     upvar #0 nick_onchans($nl) oc
 672     upvar #0 chan_nicks($lchan) nlist
 673     if {![info exists oc]} {
 674         global marktime_join_startdelay
 675         lnick_marktime_start $nl "Welcome." $marktime_join_startdelay 1
 676     }
 677     lappend oc $lchan
 678     lappend nlist $nl
 679 }
 680 proc msg_PART {p c chan args} {
 681     prefix_nick
 682     set msg "leaving $chan"
 683     if {[llength $args]} {
 684         set why [lindex $args 0]
 685         if {"[irctolower $why]" != "[irctolower $n]"} { append msg " ($why)" }
 686     }
 687     recordlastseen_n $n $msg 1
 688     process_kickpart $chan $n
 689 }
 690 proc msg_QUIT {p c why} {
 691     prefix_nick
 692     recordlastseen_n $n "leaving ($why)" 0
 693     nick_forget $n
 694 }
 695
 696 proc msg_PRIVMSG {p c dest text} {
 697     global errorCode
 698
 699     prefix_nick
 700     if {[ischan $dest]} {
 701         recordlastseen_n $n "invoking me in $dest" 1
 702         set output $dest
 703     } else {
 704         recordlastseen_n $n "talking to me" 1
 705         set output $n
 706     }
 707     nick_case $n
 708
 709     execute_usercommand $p $c $n $output $dest $text
 710 }
 711
 712 proc msg_INVITE {p c n chan} {
 713     after 1000 [list dojoin [irctolower $chan]]
 714 }
 715
 716 proc grep {var predicate list} {
 717     set o {}
 718     upvar 1 $var v
 719     foreach v $list {
 720         if {[uplevel 1 [list expr $predicate]]} { lappend o $v }
 721     }
 722     return $o
 723 }
 724
 725 proc msg_353 {p c dest type chan nicklist} {
 726     global names_chans nick_onchans
 727     set lchan [irctolower $chan]
 728     upvar #0 chan_nicks($lchan) nlist
 729     lappend names_chans $lchan
 730     if {![info exists nlist]} {
 731         # We don't think we're on this channel, so ignore it !
 732         # Unfortunately, because we don't get a reply to PART,
 733         # we have to remember ourselves whether we're on a channel,
 734         # and ignore stuff if we're not, to avoid races.  Feh.
 735         return
 736     }
 737     set nlist_new {}
 738     foreach user [split $nicklist { }] {
 739         regsub {^[@+]} $user {} user
 740         if {![string length $user]} continue
 741         check_nick $user
 742         set luser [irctolower $user]
 743         upvar #0 nick_onchans($luser) oc
 744         lappend oc $lchan
 745         lappend nlist_new $luser
 746         nick_ishere $user
 747     }
 748     set nlist $nlist_new
 749 }
 750
 751 proc msg_366 {p c args} {
 752     global names_chans nick_onchans
 753     set lchan [irctolower $c]
 754     foreach luser [array names nick_onchans] {
 755         upvar #0 nick_onchans($luser) oc
 756         if {[llength names_chans] > 1} {
 757             set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc]
 758         }
 759         if {![llength $oc]} { lnick_forget $n }
 760     }
 761     unset names_chans
 762 }
 763
 764 proc check_username {target} {
 765     if {
 766         [string length $target] > 8 ||
 767         [regexp {[^-0-9a-z]} $target] ||
 768         ![regexp {^[a-z]} $target]
 769     } { error "invalid username" }
 770 }
 771
 772 proc somedb__head {} {
 773     uplevel 1 {
 774         set idl [irctolower $id]
 775         upvar #0 ${nickchan}db($idl) ndbe
 776         binary scan $idl H* idh
 777         set idfn $fprefix$idh
 778         if {![info exists iddbe] && [file exists $idfn]} {
 779             set f [open $idfn r]
 780             try_except_finally { set newval [read $f] } {} { close $f }
 781             if {[llength $newval] % 2} { error "invalid length" }
 782             set iddbe $newval
 783         }
 784     }
 785 }
 786
 787 proc def_somedb {name arglist body} {
 788     foreach {nickchan fprefix} {
 789         nick users/n
 790         chan chans/c
 791         msgs users/m
 792     } {
 793         proc ${nickchan}db_$name $arglist \
 794             "set nickchan $nickchan; set fprefix $fprefix; $body"
 795     }
 796 }
 797
 798 def_somedb list {} {
 799     set list {}
 800     foreach path [glob -nocomplain -path $fprefix *] {
 801         binary scan $path "A[string length $fprefix]A*" afprefix thinghex
 802         if {"$afprefix" != "$fprefix"} { error "wrong prefix $path $afprefix" }
 803         lappend list [binary format H* $thinghex]
 804     }
 805     return $list
 806 }
 807
 808 proc def_somedb_id {name arglist body} {
 809     def_somedb $name [concat id $arglist] "somedb__head; $body"
 810 }
 811
 812 def_somedb_id exists {} {
 813     return [info exists iddbe]
 814 }
 815
 816 def_somedb_id delete {} {
 817     catch { unset iddbe }
 818     file delete $idfn
 819 }
 820
 821 set default_settings_nick {
 822     timeformat ks
 823     marktime off
 824     tellsec {secure 600}
 825     tellrel {remind 3600 30}
 826 }
 827
 828 set default_settings_chan {
 829     autojoin 1
 830     mode *
 831     userinvite pub
 832     topicset {}
 833     topicsee {}
 834     topictell {}
 835 }
 836
 837 set default_settings_msgs {
 838     inbound {}
 839     outbound {}
 840 }
 841 # inbound -> [<nick> <time_t> <message>] ...
 842 # outbound -> [<nick> <time_t(earliest)> <count>] ...
 843 #   neither are sorted particularly; only one entry per recipient in
 844 #   output; both sender and recipient are cased
 845
 846 def_somedb_id set {args} {
 847     upvar #0 default_settings_$nickchan def
 848     if {![info exists iddbe]} { set iddbe $def }
 849     foreach {key value} [concat $iddbe $args] { set a($key) $value }
 850     set newval {}
 851     foreach {key value} [array get a] { lappend newval $key $value }
 852     set f [open $idfn.new w]
 853     try_except_finally {
 854         puts $f $newval
 855         close $f
 856         file rename -force $idfn.new $idfn
 857     } {
 858     } {
 859         catch { close $f }
 860     }
 861     set iddbe $newval
 862 }
 863
 864 def_somedb_id get {key} {
 865     upvar #0 default_settings_$nickchan def
 866     if {[info exists iddbe]} {
 867         set l [concat $iddbe $def]
 868     } else {
 869         set l $def
 870     }
 871     foreach {tkey value} $l {
 872         if {"$tkey" == "$key"} { return $value }
 873     }
 874     error "unset setting $key"
 875 }
 876
 877 proc opt {key} {
 878     global calling_nick
 879     if {[info exists calling_nick]} { set n $calling_nick } { set n {} }
 880     return [nickdb_get $n $key]
 881 }
 882
 883 proc check_notonchan {} {
 884     upvar 1 dest dest
 885     if {[ischan $dest]} { usererror "That command must be sent privately." }
 886 }
 887
 888 proc nick_securitycheck {strict} {
 889     upvar 1 n n
 890     if {![nickdb_exists $n]} {
 891         usererror "You are unknown to me, use `register'."
 892     }
 893     set wantu [nickdb_get $n username]
 894     if {![string length $wantu]} {
 895         if {$strict} {
 896             usererror "That feature is only available to secure users, sorry."
 897         } else {
 898             return
 899         }
 900     }
 901     set luser [irctolower $n]
 902     upvar #0 nick_username($luser) nu
 903     if {![info exists nu]} {
 904         usererror "Nick $n is secure, you must identify yourself first."
 905     }
 906     if {"$wantu" != "$nu"} {
 907         usererror "You are the wrong user -\
 908                 the nick $n belongs to $wantu, not $nu."
 909     }
 910 }
 911
 912 proc channel_ismanager {channel n} {
 913     set mgrs [chandb_get $channel managers]
 914     return [expr {[lsearch -exact [irctolower $mgrs] [irctolower $n]] >= 0}]
 915 }
 916
 917 proc channel_securitycheck {channel} {
 918     upvar n n
 919     if {![channel_ismanager $channel $n]} {
 920         usererror "You are not a manager of $channel."
 921     }
 922     nick_securitycheck 1
 923 }
 924
 925 proc def_chancmd {name body} {
 926     proc channel/$name {} \
 927             "    upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body"
 928 }
 929
 930 proc ta_listop {findnow procvalue} {
 931     # findnow and procvalue are code fragments which will be executed
 932     # in the caller's level.  findnow should set ta_listop_ev to
 933     # the current list, and procvalue should treat ta_listop_ev as
 934     # a proposed value in the list and check and possibly modify
 935     # (canonicalise?) it.  After ta_listop, ta_listop_ev will
 936     # be the new value of the list.
 937     upvar 1 ta_listop_ev exchg
 938     upvar 1 text text
 939     set opcode [ta_word]
 940     switch -exact _$opcode {
 941         _= { }
 942         _+ - _- {
 943             uplevel 1 $findnow
 944             foreach item $exchg { set array($item) 1 }
 945         }
 946         default {
 947             error "list change opcode must be one of + - ="
 948         }
 949     }
 950     foreach exchg [split $text " "] {
 951         if {![string length $exchg]} continue
 952         uplevel 1 $procvalue
 953         if {"$opcode" != "-"} {
 954             set array($exchg) 1
 955         } else {
 956             catch { unset array($exchg) }
 957         }
 958     }
 959     set exchg [lsort [array names array]]
 960 }
 961
 962 def_chancmd manager {
 963     ta_listop {
 964         if {[chandb_exists $chan]} {
 965             set ta_listop_ev [chandb_get $chan managers]
 966         } else {
 967             set ta_listop_ev [list [irctolower $n]]
 968         }
 969     } {
 970         check_nick $ta_listop_ev
 971         set ta_listop_ev [irctolower $ta_listop_ev]
 972     }
 973     if {[llength $ta_listop_ev]} {
 974         chandb_set $chan managers $ta_listop_ev
 975         ucmdr "Managers of $chan: $ta_listop_ev" {}
 976     } else {
 977         chandb_delete $chan
 978         ucmdr {} {} "forgets about managing $chan." {}
 979     }
 980 }
 981
 982 def_chancmd autojoin {
 983     set yesno [ta_word]
 984     switch -exact [string tolower $yesno] {
 985         no { set nv 0 }
 986         yes { set nv 1 }
 987         default { error "channel autojoin must be `yes' or `no' }
 988     }
 989     chandb_set $chan autojoin $nv
 990     ucmdr [expr {$nv ? "I will join $chan when I'm restarted " : \
 991             "I won't join $chan when I'm restarted "}] {}
 992 }
 993
 994 def_chancmd userinvite {
 995     set nv [string tolower [ta_word]]
 996     switch -exact $nv {
 997         pub { set txt "!invite will work for $chan, but it won't work by /msg" }
 998         here { set txt "!invite and /msg invite will work, but only for users who are already on $chan." }
 999         all { set txt "Any user will be able to invite themselves or anyone else to $chan." }
1000         none { set txt "I will not invite anyone to $chan." }
1001         default {
1002             error "channel userinvite must be `pub', `here', `all' or `none'
1003         }
1004     }
1005     chandb_set $chan userinvite $nv
1006     ucmdr $txt {}
1007 }
1008
1009 def_chancmd topic {
1010     set what [ta_word]
1011     switch -exact $what {
1012         leave {
1013             ta_nomore
1014             chandb_set $chan topicset {}
1015             ucmdr "I won't ever change the topic of $chan." {}
1016         }
1017         set {
1018             set t [string trim $text]
1019             if {![string length $t]} {
1020                 error "you must specific the topic to set"
1021             }
1022             chandb_set $chan topicset $t
1023             ucmdr "Whenever I'm alone on $chan, I'll set the topic to $t." {}
1024         }
1025         see - tell {
1026             ta_listop {
1027                 set ta_listop_ev [chandb_get $chan topic$what]
1028             } {
1029                 if {"$ta_listop_ev" != "*"} {
1030                     if {![ischan $ta_listop_ev]} {
1031                         error "bad channel \`$ta_listop_ev' in topic $what"
1032                     }
1033                     set ta_listop_ev [irctolower $ta_listop_ev]
1034                 }
1035             }
1036             chandb_set $chan topic$what $ta_listop_ev
1037             ucmdr "Topic $what list for $chan: $ta_listop_ev" {}
1038         }
1039         default {
1040             usererror "Unknown channel topic subcommand - see help channel."
1041         }
1042     }
1043 }
1044
1045 def_chancmd mode {
1046     set mode [ta_word]
1047     if {"$mode" != "*" && ![regexp {^(([-+][imnpst]+)+)$} $mode mode]} {
1048         error {channel mode must be * or match ([-+][imnpst]+)+}
1049     }
1050     chandb_set $chan mode $mode
1051     if {"$mode" == "*"} {
1052         ucmdr "I won't ever change the mode of $chan." {}
1053     } else {
1054         ucmdr "Whenever I'm alone on $chan, I'll set the mode to $mode." {}
1055     }
1056 }
1057
1058 def_chancmd show {
1059     if {[chandb_exists $chan]} {
1060         set l "Settings for $chan: autojoin "
1061         append l [lindex {no yes} [chandb_get $chan autojoin]]
1062         append l ", mode " [chandb_get $chan mode]
1063         append l ", userinvite " [chandb_get $chan userinvite] "."
1064         append l "\nManagers: "
1065         append l [join [chandb_get $chan managers] " "]
1066         foreach {ts sep} {see "\n" tell "  "} {
1067             set t [chandb_get $chan topic$ts]
1068             append l $sep
1069             if {[llength $t]} {
1070                 append l "Topic $ts list: $t."
1071             } else {
1072                 append l "Topic $ts list is empty."
1073             }
1074         }
1075         append l "\n"
1076         set t [chandb_get $chan topicset]
1077         if {[string length $t]} {
1078             append l "Topic to set: $t"
1079         } else {
1080             append l "I will not change the topic."
1081         }
1082         ucmdr {} $l
1083     } else {
1084         ucmdr {} "The channel $chan is not managed."
1085     }
1086 }
1087
1088 proc channelmgr_monoop {} {
1089     upvar 1 dest dest
1090     upvar 1 text text
1091     upvar 1 n n
1092     upvar 1 p p
1093     upvar 1 target target
1094     global chan_nicks
1095
1096     prefix_nick
1097
1098     if {[ischan $dest]} { set target $dest }
1099     if {[ta_anymore]} { set target [ta_word] }
1100     ta_nomore
1101     if {![info exists target]} {
1102         usererror "You must specify, or invoke me on, the relevant channel."
1103     }
1104     if {![info exists chan_nicks([irctolower $target])]} {
1105         usererror "I am not on $target."
1106     }
1107     if {![ischan $target]} { error "not a valid channel" }
1108
1109     if {![chandb_exists $target]} {
1110         usererror "$target is not a managed channel."
1111     }
1112     channel_securitycheck $target
1113 }
1114
1115 def_ucmd op {
1116     channelmgr_monoop
1117     sendout MODE $target +o $n
1118 }
1119
1120 def_ucmd leave {
1121     channelmgr_monoop
1122     doleave $target
1123 }
1124
1125 def_ucmd invite {
1126     global chan_nicks errorCode errorInfo
1127     prefix_nick
1128
1129     if {[ischan $dest]} {
1130         set target $dest
1131         set onchan 1
1132     } else {
1133         set target [ta_word]
1134         set onchan 0
1135     }
1136     set ltarget [irctolower $target]
1137     if {![ischan $target]} { error "$target is not a channel" }
1138     if {![info exists chan_nicks($ltarget)]} {
1139         usererror "I am not on $target."
1140     }
1141     set ui [chandb_get $ltarget userinvite]
1142     if {[catch {
1143         if {"$ui" == "pub" && !$onchan} {
1144             usererror "Invitations to $target must be made there with !invite."
1145         }
1146         if {"$ui" != "all"} {
1147             if {[lsearch -exact $chan_nicks($ltarget) [irctolower $n]] < 0} {
1148                 usererror "Invitations to $target may only be made\
1149                         by a user on the channel."
1150             }
1151         }
1152         if {"$ui" == "none"} {
1153             usererror "Sorry, I've not been authorised\
1154                     to invite people to $target."
1155         }
1156     } emsg]} {
1157         if {"$errorCode" == "BLIGHT USER" && [channel_ismanager $target $n]} {
1158             if {[catch {
1159                 nick_securitycheck 1
1160             } emsg2]} {
1161                 if {"$errorCode" == "BLIGHT USER"} {
1162                     usererror "$emsg2  Therefore you can't use your\
1163                             channel manager privilege.  $emsg"
1164                 } else {
1165                     error $error $errorInfo $errorCode
1166                 }
1167             }
1168         } else {
1169             error $emsg $errorInfo $errorCode
1170         }
1171     }
1172     if {![ta_anymore]} {
1173         usererror "You have to say who to invite."
1174     }
1175     set invitees {}
1176     while {[ta_anymore]} {
1177         set invitee [ta_word]
1178         check_nick $invitee
1179         lappend invitees $invitee
1180     }
1181     foreach invitee $invitees {
1182         sendout INVITE $invitee $ltarget
1183     }
1184     set who [lindex $invitees 0]
1185     switch -exact llength $invitees {
1186         0 { error "zero invitees" }
1187         1 { }
1188         2 { append who " and [lindex $invitees 1]" }
1189         * {
1190             set who [join [lreplace $invitees end end] ", "]
1191             append who " and [lindex $invitees [llength $invitees]]"
1192         }
1193     }
1194     ucmdr {} {} {} "invites $who to $target."
1195 }
1196
1197 def_ucmd channel {
1198     if {[ischan $dest]} { set target $dest }
1199     if {![ta_anymore]} {
1200         set subcmd show
1201     } else {
1202         set subcmd [ta_word]
1203     }
1204     if {[ischan $subcmd]} {
1205         set target $subcmd
1206         if {![ta_anymore]} {
1207             set subcmd show
1208         } else {
1209             set subcmd [ta_word]
1210         }
1211     }
1212     if {![info exists target]} { error "privately, you must specify a channel" }
1213     set procname channel/$subcmd
1214     if {"$subcmd" != "show"} {
1215         if {[catch { info body $procname }]} {
1216             usererror "unknown channel setting $subcmd."
1217         }
1218         prefix_nick
1219         if {[chandb_exists $target]} {
1220             channel_securitycheck $target
1221         } else {
1222             nick_securitycheck 1
1223             upvar #0 chan_initialop([irctolower $target]) io
1224             upvar #0 nick_unique([irctolower $n]) u
1225             if {![info exists io]} {
1226                 usererror "$target is not a managed channel."
1227             }
1228             if {"$io" != "$u"} {
1229                 usererror "You are not the interim manager of $target."
1230             }
1231             if {"$subcmd" != "manager"} {
1232                 usererror "Please use `channel manager' first."
1233             }
1234         }
1235     }
1236     channel/$subcmd
1237 }
1238
1239 proc nickdb_get_username {n} {
1240     if {![nickdb_exists $n]} { return "" }
1241     return [nickdb_get $n username]
1242 }
1243
1244 proc nickdb_get_sec_effective {n} {
1245     set l [nickdb_get $n tellsec]
1246     set u [nickdb_get_username $n]
1247     if {"[lindex $l 0]" == "secure" && ![string length $u]} { set l insecure }
1248     return $l
1249 }
1250
1251 proc tell_peernicks {text} {
1252     set text [irctolower [string trim $text]]
1253     set senders [split $text " "]
1254     foreach sender $senders {
1255         if {[catch { check_nick $sender } emsg]} {
1256             error "invalid sender nick `$sender': $emsg" $errorInfo $errorCode
1257         }
1258     }
1259     return $senders
1260 }
1261
1262 proc msgsdb_set_maydelete {n key l otherkey} {
1263     msgsdb_set $n $key $l
1264     if {[llength $l]} return
1265     if {[llength [msgsdb_get $n $otherkey]]} return
1266     msgsdb_delete $n
1267 }
1268
1269 proc tell_delete_msgs {lsenders lrecip} {
1270     set ninbound {}
1271     set ndel 0
1272     foreach {s t m} [msgsdb_get $lrecip inbound] {
1273         if {[llength $lsenders]} {
1274             if {[lsearch -exact $lsenders [irctolower $s]] == -1} {
1275                 lappend ninbound $s $t $m
1276                 continue
1277             }
1278         }
1279         set rsenders($s) 1
1280         incr ndel
1281     }
1282     msgsdb_set_maydelete $lrecip inbound $ninbound outbound
1283     if {![llength $ninbound]} {
1284         upvar #0 nick_telling($lrecip) telling
1285         catch { unset telling }
1286     }
1287     foreach s [array names rsenders] {
1288         set noutbound {}
1289         foreach {r t c} [msgsdb_get $s outbound] {
1290             if {"[irctolower $r]" == "$lrecip"} continue
1291             lappend noutbound $r $t $c
1292         }
1293         msgsdb_set_maydelete $s outbound $noutbound inbound
1294     }
1295     return $ndel
1296 }
1297
1298 def_ucmd untell {
1299     prefix_nick
1300     check_notonchan
1301     nick_securitycheck 0
1302     set recipients [tell_peernicks $text]
1303     if {![llength $recipients]} {
1304         usererror "You must say which recipients' messages from you to forget."
1305     }
1306     set ndel 0
1307     foreach recip $recipients {
1308         incr ndel [tell_delete_msgs [irctolower $n] $recip]
1309     }
1310     ucmdr "Removed $ndel as yet undelivered message(s)." {}
1311 }
1312
1313 def_ucmd delmsg {
1314     global errorInfo errorCode
1315     prefix_nick
1316     set nl [irctolower $n]
1317     check_notonchan
1318     manyset [nickdb_get_sec_effective $n] sec secwhen
1319     switch -exact $sec {
1320         insecure { }
1321         refuse - mailto {
1322             usererror \
1323  "There are no messages to delete\
1324  because your message disposition prevents them from being left."
1325         }
1326         secure {
1327             nick_securitycheck 1
1328         }
1329         default {
1330             error "delmsg sec $sec"
1331         }
1332     }
1333     tell_getcstate
1334     if {"$stt" != "passed"} {
1335         usererror \
1336  "There are message(s) you've not yet seen; I'll deliver them to you now.\
1337   If you actually want to delete them, just tell me `delmsg' again."
1338     }
1339     set senders [tell_peernicks $text]
1340     set ndel [tell_delete_msgs [irctolower $senders] [irctolower $n]]
1341     if {!$ndel} {
1342         if {[llength $senders]} {
1343             ucmdr "No relevant incoming messages to delete." {}
1344         } else {
1345             ucmdr "No incoming messages to delete." {}
1346         }
1347     }
1348     switch -exact [llength $senders] {
1349         0 { ucmdr {} {} "deletes your $ndel message(s)." }
1350         1 { ucmdr {} {} "deletes your $ndel message(s) from $senders." }
1351         default {
1352             ucmdr {} {} "deletes your $ndel message(s) from\
1353  [lreplace $senders end end] and [lindex $senders end]."
1354         }
1355     }
1356 }
1357
1358 def_ucmd tellme {
1359     prefix_nick
1360     ta_nomore
1361     check_notonchan
1362     switch -exact [tell_event [irctolower $n] tellme] {
1363         ERROR - INVALID { ucmdr {} {is ill.  Help!} }
1364         nomsgs { ucmdr {You have no messages.} {} }
1365         default { }
1366     }
1367 }
1368
1369 def_ucmd tell {
1370     global nick_case ownmailaddr ownfullname
1371
1372     prefix_nick
1373     set target [ta_word]
1374     if {![string length $text]} { error "tell them what?" }
1375     if {[string length $text] > 400} { error "message too long" }
1376
1377     set ltarget [irctolower $target]
1378     set ctarget $target
1379     if {[info exists nick_case($ltarget)]} { set ctarget $nick_case($ltarget) }
1380
1381     manyset [nickdb_get_sec_effective $target] sec mailtoint mailwhy
1382     manyset [nickdb_get $target tellrel] rel relint relwithin
1383     switch -exact $sec {
1384         insecure - secure {
1385             set now [clock seconds]
1386             set inbound [msgsdb_get $ltarget inbound]
1387             lappend inbound $n $now $text
1388             msgsdb_set $ltarget inbound $inbound
1389
1390             set outbound [msgsdb_get $n outbound]
1391             set noutbound {}
1392             set found 0
1393             foreach {recip time count} $outbound {
1394                 if {"[irctolower $recip]" == "$ltarget"} {
1395                     incr count
1396                     set recip $ctarget
1397                     set found 1
1398                 }
1399                 lappend noutbound $recip $time $count
1400             }
1401             if {!$found} {
1402                 lappend noutbound $ctarget $now 1
1403             }
1404             msgsdb_set $n outbound $noutbound
1405             set msg "OK, I'll tell $ctarget"
1406             if {$found} { append msg " that too" }
1407             append msg ", "
1408             if {"$sec" != "secure"} {
1409                 switch -exact $rel {
1410                     unreliable { append msg "neither reliably nor securely" }
1411                     remind { append msg "pretty reliably, but not securely" }
1412                     pester { append msg "reliably but not securely" }
1413                 }
1414             } else {
1415                 switch -exact $rel {
1416                     unreliable { append msg "securely but not reliably" }
1417                     remind { append msg "securely and pretty reliably" }
1418                     pester { append msg "reliably and securely" }
1419                 }
1420             }
1421             append msg .
1422             tell_event $ltarget msgsarrive
1423             ucmdr $msg {}
1424         }
1425         mailto {
1426             set fmtmsg [exec fmt << " $text"]
1427             exec /usr/sbin/sendmail -odb -oi -t -oee -f $mailwhy \
1428                     > /dev/null << \
1429  "From: $ownmailaddr ($ownfullname)
1430 To: $mailtoint
1431 Subject: IRC tell from $n
1432
1433 $n asked me[expr {[ischan $dest] ? " on $dest" : ""}] to tell you:
1434 [exec fmt << " $text"]
1435
1436 (This message was for your nick $ctarget; your account $mailwhy
1437  arranged for it to be forwarded to $mailtoint.)
1438 "
1439             ucmdr \
1440  "I've mailed $ctarget, which is what they prefer." \
1441                 {}
1442         }
1443         refuse {
1444             usererror "Sorry, $ctarget does not want me to take messages."
1445         }
1446         default {
1447             error "bad tellsec $sec"
1448         }
1449     }
1450 }
1451
1452 def_ucmd who {
1453     if {[ta_anymore]} {
1454         set target [ta_word]; ta_nomore
1455         set myself 1
1456     } else {
1457         prefix_nick
1458         set target $n
1459         set myself [expr {"$target" != "$n"}]
1460     }
1461     set ltarget [irctolower $target]
1462     upvar #0 nick_case($ltarget) ctarget
1463     set nshow $target
1464     if {[info exists ctarget]} {
1465         upvar #0 nick_onchans($ltarget) oc
1466         upvar #0 nick_username($ltarget) nu
1467         if {[info exists oc]} { set nshow $ctarget }
1468     }
1469     if {![nickdb_exists $ltarget]} {
1470         set ol "$nshow is not a registered nick."
1471     } elseif {[string length [set username [nickdb_get $target username]]]} {
1472         set ol "The nick $nshow belongs to the user $username."
1473     } else {
1474         set ol "The nick $nshow is registered (but not to a username)."
1475     }
1476     if {![info exists ctarget] || ![info exists oc]} {
1477         if {$myself} {
1478             append ol "\nI can't see $nshow on anywhere."
1479         } else {
1480             append ol "\nYou aren't on any channels with me."
1481         }
1482     } elseif {![info exists nu]} {
1483         append ol "\n$nshow has not identified themselves."
1484     } elseif {![info exists username]} {
1485         append ol "\n$nshow has identified themselves as the user $nu."
1486     } elseif {"$nu" != "$username"} {
1487         append ol "\nHowever, $nshow is being used by the user $nu."
1488     } else {
1489         append ol "\n$nshow has identified themselves to me."
1490     }
1491     ucmdr {} $ol
1492 }
1493
1494 def_ucmd register {
1495     prefix_nick
1496     check_notonchan
1497     set old [nickdb_exists $n]
1498     if {$old} { nick_securitycheck 0 }
1499     set luser [irctolower $n]
1500     switch -exact [string tolower [string trim $text]] {
1501         {} {
1502             upvar #0 nick_username($luser) nu
1503             if {![info exists nu]} {
1504                 ucmdr {} \
1505  "You must identify yourself before using `register'.  See `help identify', or use `register insecure'."
1506             }
1507             nickdb_set $n username $nu
1508             ucmdr {} {} "makes a note of your username." {}
1509         }
1510         delete {
1511             nickdb_delete $n
1512             ucmdr {} {} "forgets your nickname." {}
1513         }
1514         insecure {
1515             nickdb_set $n username {}
1516             if {$old} {
1517                 ucmdr {} "Security is now disabled for your nickname !"
1518             } else {
1519                 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."
1520             }
1521         }
1522         default {
1523             error "you mean register / register delete / register insecure"
1524         }
1525     }
1526 }
1527
1528 proc timeformat_desc {tf} {
1529     switch -exact $tf {
1530         ks { return "Times will be displayed in seconds or kiloseconds." }
1531         hms { return "Times will be displayed in hours, minutes, etc." }
1532         default { error "invalid timeformat: $v" }
1533     }
1534 }
1535
1536 set settings {}
1537 proc def_setting {opt show_body set_body} {
1538     global settings
1539     lappend settings $opt
1540     proc set_show/$opt {} "
1541         upvar 1 n n
1542         set opt $opt
1543         $show_body"
1544     if {![string length $set_body]} return
1545     proc set_set/$opt {} "
1546         upvar 1 n n
1547         upvar 1 text text
1548         set opt $opt
1549         $set_body"
1550 }
1551
1552 proc tellme_sec_desc {v n} {
1553     manyset $v sec mailtoint
1554     switch -exact $sec {
1555         insecure {
1556             return "I'll tell you your messages whenever I see you."
1557         }
1558         secure {
1559             if {[string length [nickdb_get_username $n]]} {
1560                 return \
1561  "I'll keep the bodies of your messages private until you identify yourself, reminding you every [showintervalsecs $mailtoint 1]."
1562             } else {
1563                 return \
1564  "I'll tell you your messages whenever I see you.\
1565   (Secure message delivery is enabled, but your nick is not registered\
1566  securely.  See `help register'.)"
1567             }
1568         }
1569         refuse {
1570             return "I shan't accept messages for you."
1571         }
1572         mailto {
1573             return "I'll forward your messages by email to $mailtoint."
1574         }
1575         default {
1576             error "bad tellsec $sec"
1577         }
1578     }
1579 }
1580
1581 proc tellme_rel_desc {v} {
1582     manyset $v rel every within
1583     switch -exact $rel {
1584         unreliable {
1585             return "As soon as I've told you message(s), I'll forget them\
1586  - note that this means messages can get lost !"
1587         }
1588         pester {
1589             set u {}
1590         }
1591         remind {
1592             set u ", or talk on channel within [showintervalsecs $within 1] of me having told you"
1593         }
1594         default {
1595             error "bad tellrel $rel"
1596         }
1597     }
1598     return "After delivering messages, I'll remind you every\
1599  [showintervalsecs $every 1] until you say delmsg$u."
1600 }
1601
1602 def_setting timeformat {
1603     set tf [nickdb_get $n timeformat]
1604     return "$tf: [timeformat_desc $tf]"
1605 } {
1606     set tf [string tolower [ta_word]]
1607     ta_nomore
1608     set desc [timeformat_desc $tf]
1609     nickdb_set $n timeformat $tf
1610     ucmdr {} $desc
1611 }
1612
1613 proc marktime_desc {mt} {
1614     if {"$mt" == "off"} {
1615         return "I will not send you periodic messages."
1616     } elseif {"$mt" == "once"} {
1617         return "I will send you one informational message when I see you."
1618     } else {
1619         return "I'll send you a message every [showintervalsecs $mt 0]."
1620     }
1621 }
1622
1623 def_setting marktime {
1624     set mt [nickdb_get $n marktime]
1625     set p $mt
1626     if {[string match {[0-9]*} $mt]} { append p s }
1627     append p ": "
1628     append p [marktime_desc $mt]
1629     return $p
1630 } {
1631     global marktime_min
1632     set mt [string tolower [ta_word]]
1633     ta_nomore
1634
1635     if {"$mt" == "off" || "$mt" == "once"} {
1636     } else {
1637         set mt [parse_interval $mt $marktime_min]
1638     }
1639     nickdb_set $n marktime $mt
1640     lnick_marktime_start [irctolower $n] "So:" 500 0
1641     ucmdr {} [marktime_desc $mt]
1642 }
1643
1644 def_setting security {
1645     set s [nickdb_get $n username]
1646     if {[string length $s]} {
1647         return "Your nick, $n, is controlled by the user $s."
1648     } else {
1649         return "Your nick, $n, is not secure."
1650     }
1651 } {}
1652
1653 proc tellme_setting_sec_simple {} {
1654     uplevel 1 {
1655         ta_nomore
1656         set sr sec
1657         set v $setting
1658     }
1659 }
1660
1661 proc tellme_setting_neednomsgs {} {
1662     uplevel 1 {
1663         if {[llength [msgsdb_get $n inbound]]} {
1664             usererror "You must delete the messages you have, first."
1665         }
1666     }
1667 }
1668
1669 def_setting tellme {
1670     set secv [nickdb_get $n tellsec]
1671     set ms [tellme_sec_desc $secv $n]
1672     manyset $secv sec
1673     switch -exact $sec {
1674         insecure - secure {
1675             set mr [tellme_rel_desc [nickdb_get $n tellrel]]
1676             return "$ms  $mr"
1677         }
1678         refuse - mailto {
1679             return $ms
1680         }
1681     }
1682 } {
1683     set setting [string tolower [ta_word]]
1684     switch -exact $setting {
1685         insecure {
1686             tellme_setting_sec_simple
1687         }
1688         secure {
1689             set every [ta_interval_optional 60 600]
1690             ta_nomore
1691             set sr sec
1692             set v [list secure $every]
1693         }
1694         refuse {
1695             telling_setting_neednomsgs
1696             telling_setting_sec_simple
1697         }
1698         mailto {
1699             telling_setting_neednomsgs
1700
1701             if {[string length [set u [nickdb_get_username $n]]]} {
1702                 usererror \
1703  "Sorry, you must register securely to have your messages mailed\
1704  (to prevent the use of this feature for spamming).  See `help register'."
1705             }
1706             set sr sec
1707             set v [list mailto [ta_word] $u]
1708         }
1709         unreliable - pester - remind {
1710             manyset [nickdb_get $n tellsec] sec
1711             switch -exact $sec {
1712                 refuse - mailto {
1713                     usererror \
1714  "You can't change your message delivery conditions when\
1715  your message disposition prevents messages from being left."
1716                 }
1717             }
1718             set sr rel
1719             set v $setting
1720             if {"$setting" != "unreliable"} {
1721                 set every [parse_interval_optional 300 3600]
1722                 lappend v $every
1723             }
1724             if {"$setting" == "remind"} {
1725                 set within [ta_interval_optional 5 30]
1726                 if {$within > $every} {
1727                     error "remind interval must be at least time to respond"
1728                 }
1729                 lappend v $within
1730             }
1731             ta_nomore
1732         }
1733         default {
1734             error "invalid tellme setting $setting"
1735         }
1736     }
1737     nickdb_set $n tell$sr $v
1738     ucmdr [tellme_${sr}_desc $v] {}
1739 }
1740
1741 proc lnick_checktold {luser} {
1742     set ml [msgsdb_get $luser outbound]
1743     if {![llength $ml]} return
1744     set is1 [expr {[llength $ml]==3}]
1745     set m1 "FYI, I haven't yet passed on your"
1746     set ol {}
1747     set now [clock seconds]
1748     while {[llength $ml]} {
1749         manyset $ml r t n
1750         set ml [lreplace $ml 0 2]
1751         set td [expr {$now-$t}]
1752         if {$n == 1} {
1753             set iv [showinterval $td]
1754             set ifo "$r, $iv"
1755             set if1 "message to $r, $iv."
1756         } else {
1757             set iv [showintervalsecs $td 0]
1758             set ifo "$r, $n messages, oldest $iv"
1759             set if1 "$n messages to $r, oldest $iv."
1760         }
1761         if {$is1} {
1762             sendprivmsg $luser "$m1 $if1"
1763             return
1764         } else {
1765             lappend ol " to $ifo[expr {[llength $ml] ? ";" : "."}]"
1766         }
1767     }
1768     sendprivmsg $luser "$m1 messages:"
1769     msendprivmsg $luser $ol
1770 }
1771
1772 def_ucmd set {
1773     global settings
1774     prefix_nick
1775     check_notonchan
1776     if {![nickdb_exists $n]} {
1777         ucmdr {} "You are unknown to me and so have no settings.  (Use `register'.)"
1778     }
1779     if {![ta_anymore]} {
1780         set ol {}
1781         foreach opt $settings {
1782             lappend ol [format "%-10s %s" $opt [set_show/$opt]]
1783         }
1784         ucmdr {} [join $ol "\n"]
1785     } else {
1786         set opt [ta_word]
1787         if {[catch { info body set_show/$opt }]} {
1788             error "no setting $opt"
1789         }
1790         if {![ta_anymore]} {
1791             ucmdr {} "$opt: [set_show/$opt]"
1792         } else {
1793             nick_securitycheck 0
1794             if {[catch { info body set_set/$opt }]} {
1795                 error "setting $opt cannot be set with `set'"
1796             }
1797             set_set/$opt
1798         }
1799     }
1800 }
1801
1802 def_ucmd identpass {
1803     prefix_nick
1804     check_notonchan
1805     set luser [irctolower $n]
1806     set username [ta_word]
1807     set passmd5 [md5sum "[ta_word]\n"]
1808     ta_nomore
1809     upvar #0 nick_onchans($luser) onchans
1810     if {![info exists onchans] || ![llength $onchans]} {
1811         ucmdr "You must be on a channel with me to identify yourself." {}
1812     }
1813     check_username $username
1814     exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \
1815             irc-identpass $n
1816     upvar #0 nick_username($luser) rec_username
1817     set rec_username $username
1818     ucmdr "Pleased to see you, $username." {}
1819     tell_event $luser ident
1820 }
1821
1822 def_ucmd summon {
1823     set target [ta_word]
1824     ta_nomore
1825     check_username $target
1826     prefix_nick
1827
1828     upvar #0 lastsummon($target) ls
1829     set now [clock seconds]
1830     if {[info exists ls]} {
1831         set interval [expr {$now - $ls}]
1832         if {$interval < 30} {
1833             ucmdr {} \
1834  "Please be patient; $target was summoned only [showinterval $interval]."
1835         }
1836     }
1837     regsub {^[^!]*!} $p {} path
1838     if {[catch {
1839         exec userv --timeout 3 $target irc-summon $n $path \
1840                 [expr {[ischan $dest] ? "$dest" : ""}] \
1841                 < /dev/null
1842     } rv]} {
1843         regsub -all "\n" $rv { / } rv
1844         error $rv
1845     }
1846     if {[regexp {^problem (.*)} $rv dummy problem]} {
1847         ucmdr {} "The user `$target' $problem."
1848     } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} {
1849         set idletime [expr {$now - $idlesince}]
1850         set ls $now
1851         ucmdr {} {} {} "invites $target ($tty[expr {
1852             $idletime > 10 ? ", idle for [showintervalsecs $idletime 0]" : ""
1853         }]) to [expr {
1854             [ischan $dest] ? "join us here" : "talk to you"
1855         }]."
1856     } else {
1857         error "unexpected response from userv service: $rv"
1858     }
1859 }
1860
1861 proc md5sum {value} { exec md5sum << $value }
1862
1863 def_ucmd seen {
1864     global lastseen nick
1865     prefix_nick
1866     set ncase [ta_nick]
1867     set nlower [irctolower $ncase]
1868     ta_nomore
1869     set now [clock seconds]
1870     if {"$nlower" == "[irctolower $nick]"} {
1871         usererror "I am not self-aware."
1872     } elseif {![info exists lastseen($nlower)]} {
1873         set rstr "I've never seen $ncase."
1874     } else {
1875         manyset $lastseen($nlower) realnick time what
1876         set howlong [expr {$now - $time}]
1877         set string [showinterval $howlong]
1878         set rstr "I last saw $realnick $string, $what."
1879     }
1880     if {[ischan $dest]} {
1881         set where $dest
1882     } else {
1883         set where {}
1884     }
1885     upvar #0 lookedfor($nlower) lf
1886     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
1887     set lf [list [list $now $n $where]]
1888     foreach v $oldvalue {
1889         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
1890         lappend lf $v
1891     }
1892     ucmdr {} $rstr
1893 }
1894
1895 proc lnick_marktime_cancel {luser} {
1896     upvar #0 nick_markid($luser) mi
1897     if {![info exists mi]} return
1898     catch { after cancel $mi }
1899     catch { unset mi }
1900 }
1901
1902 proc lnick_marktime_doafter {luser why ms mentiontold} {
1903     lnick_marktime_cancel $luser
1904     upvar #0 nick_markid($luser) mi
1905     set mi [after $ms [list lnick_marktime_now $luser $why 0]]
1906 }
1907
1908 proc lnick_marktime_reset {luser} {
1909     set mt [nickdb_get $luser marktime]
1910     if {"$mt" == "off" || "$mt" == "once"} return
1911     lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] 0
1912 }
1913
1914 proc lnick_marktime_start {luser why ms mentiontold} {
1915     set mt [nickdb_get $luser marktime]
1916     if {"$mt" == "off"} {
1917         lnick_marktime_cancel $luser
1918         if {$mentiontold} { after $ms [list lnick_checktold $luser] }
1919     } else {
1920         lnick_marktime_doafter $luser $why $ms $mentiontold
1921     }
1922 }
1923
1924 proc lnick_marktime_now {luser why mentiontold} {
1925     upvar #0 nick_onchans($luser) oc
1926     global calling_nick
1927     set calling_nick $luser
1928     sendprivmsg $luser [lnick_pingstring $why $oc ""]
1929     if {$mentiontold} { after 150 [list lnick_checktold $luser] }
1930     lnick_marktime_reset $luser
1931 }
1932
1933 proc lnick_pingstring {why oc apstring} {
1934     global nick_onchans
1935     catch { exec uptime } uptime
1936     set nnicks [llength [array names nick_onchans]]
1937     if {[regexp \
1938  {^ *([0-9:apm]+) +up.*, +(\d+) users?, +load average: +([0-9., ]+) *$} \
1939             $uptime dummy time users load]} {
1940         regsub -all , $load {} load
1941         set uptime "$time  $nnicks/$users  $load"
1942     } else {
1943         append uptime ", $nnicks nicks"
1944     }
1945     if {[llength $oc]} {
1946         set best_la 0
1947         set activity quiet
1948         foreach ch $oc {
1949             upvar #0 chan_lastactivity($ch) la
1950             if {![info exists la]} continue
1951             if {$la <= $best_la} continue
1952             set since [showintervalsecs [expr {[clock seconds]-$la}] 1]
1953             set activity "$ch $since"
1954             set best_la $la
1955         }
1956     } else {
1957         set activity unseen
1958     }
1959     set str $why
1960     append str "  " $uptime "  " $activity
1961     if {[string length $apstring]} { append str "  " $apstring }
1962     return $str
1963 }
1964
1965 def_ucmd ping {
1966     prefix_nick
1967     set ln [irctolower $n]
1968     if {[ischan $dest]} {
1969         set oc [irctolower $dest]
1970     } else {
1971         global nick_onchans
1972         if {[info exists nick_onchans($ln)]} {
1973             set oc $nick_onchans($ln)
1974         } else {
1975             set oc {}
1976         }
1977         if {[llength $oc]} { lnick_marktime_reset $ln }
1978     }
1979     after 150 [list lnick_checktold $ln]
1980     ucmdr {} [lnick_pingstring "Pong!" $oc $text]
1981 }
1982
1983 proc ensure_globalsecret {} {
1984     global globalsecret
1985
1986     if {[info exists globalsecret]} return
1987     set gsfile [open /dev/urandom r]
1988     fconfigure $gsfile -translation binary
1989     set globalsecret [read $gsfile 32]
1990     binary scan $globalsecret H* globalsecret
1991     close $gsfile
1992     unset gsfile
1993 }
1994
1995 proc connected {} {
1996     foreach chan [chandb_list] {
1997         if {[chandb_get $chan autojoin]} { dojoin $chan }
1998     }
1999 }
2000
2001 ensure_globalsecret
2002 loadhelp
2003 ensure_connecting