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             set ndel [tell_delete_msgs {} $nl]
 294             sendprivmsg $nl \
 295  "I'm assuming you got the $ndel message(s) I just passed on."
 296             return delivered
 297         }
 298         pm????? {
 299             # oops, messages passed are now out of date
 300             catch_restoreei { unset telling }
 301             return reset
 302         }
 303         ?m????? {
 304             # ignore new msgs if we haven't passed yet
 305             return ignorenew
 306         }
 307         ut????? - mt????? -
 308         pt???uu - pt???rs - pt???rl - pt???p? {
 309             # ignore (any other `talk's) - act handles these
 310             return ignoretalk
 311         }
 312         ui????? -
 313         uaii?uu - uaii??l - uas?iuu - uas?i?l -
 314         mi????? - pa????l -
 315         ?Tii??? - ?Ts?i?? {
 316             # pass and then stuff
 317             if {[llength $iml] == 3} {
 318                 manyset $iml sender sentwhen msg
 319                 sendprivmsg $nl \
 320  "$sender asked me, [showinterval [expr {$now-$sentwhen}]],\
 321  to tell you: $msg"
 322             } else {
 323                 sendprivmsg $nl \
 324  "I have [expr {[llength $iml]/3}] messages for you:"
 325                 while {[llength $iml] >= 3} {
 326                     manyset [lrange $iml 0 2] sender sentwhen msg
 327                     set iml [lrange $iml 3 end]
 328                     sendprivmsg $nl \
 329  " [showintervalsecs [expr {$now-$sentwhen}] 1] <$sender> $msg"
 330                 }
 331             }
 332             if {"$rel" == "unreliable"} {
 333                 tell_delete_msgs {} $nl
 334                 return toldunreliable
 335             }
 336             set stt passed
 337             set re passed
 338         }
 339         uaslu?? {
 340             sendprivmsg $nl {You have messages (so identify yourself please).}
 341             set stt mentioned
 342             set re mentioned
 343         }
 344         ?Ts?u?? {
 345             sendprivmsg $nl {You must identify yourself to see your messages.}
 346             return ignoreuitm
 347         }
 348         masl??? {
 349             sendprivmsg $nl {Don't forget about your messages.}
 350             return remind
 351         }
 352         pi????? {
 353             return ignorepi
 354         }
 355         mass??? - pa????v - pa????s -
 356         uaii??v - uaii??s -
 357         uas?i?v - uas?i?s -
 358         uassu?? {
 359             # too soon
 360             return ignoresoon
 361         }
 362         * {
 363             error "tell_event_core nl=$nl evstate=$evstate ?"
 364         }
 365     }
 366     if {![info exists u]} {
 367         set telling [list {} undelivered $now]
 368     } else {
 369         set telling [list $u $stt $now]
 370     }
 371     return $re
 372 }
 373
 374 proc recordlastseen_n {n how here} {
 375     # here is:
 376     #   0 - nick was seen leaving (or changing to another nicks or some such)
 377     #   1 - nick was seen doing something else
 378     #   2 - nick was seen talking on channel
 379     global lastseen lookedfor
 380     set nl [irctolower $n]
 381     set now [clock seconds]
 382     set lastseen($nl) [list $n $now $how]
 383
 384     if {!$here} return
 385
 386     tell_event $nl [lindex {none act talk} $here]
 387
 388     upvar #0 lookedfor($nl) 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 {![string length [nickdb_get_username $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) -> <includes-counter>
 603 # nick_case($luser) -> $user  (valid even if no longer visible)
 604 # nick_markid($luser) -> <after id for marktime>
 605 # nick_telling($luser) -> <unique> mentioned|passed <when>
 606
 607 # chan_nicks($lchan) -> [list ... $luser ...]
 608 # chan_lastactivity($lchan) -> [clock seconds]
 609
 610 proc lnick_forget {luser} {
 611     global nick_arys chan_nicks
 612     lnick_marktime_cancel $luser
 613     foreach ary $nick_arys {
 614         upvar #0 nick_${ary}($luser) av
 615         catch { unset av }
 616     }
 617     foreach lch [array names chan_nicks] {
 618         upvar #0 chan_nicks($lch) nlist
 619         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 620         check_justme $lch
 621     }
 622 }
 623
 624 proc nick_forget {user} {
 625     global nick_arys chan_nicks
 626     lnick_forget [irctolower $user]
 627     nick_case $user
 628 }
 629
 630 proc nick_case {user} {
 631     global nick_case
 632     set nick_case([irctolower $user]) $user
 633 }
 634
 635 proc msg_NICK {p c newnick} {
 636     global nick_arys nick_case calling_nick
 637     prefix_nick
 638     recordlastseen_n $n "changing nicks to $newnick" 0
 639     set calling_nick $newnick
 640     recordlastseen_n $newnick "changing nicks from $n" 1
 641     set luser [irctolower $n]
 642     lnick_marktime_cancel $luser
 643     set lusernew [irctolower $newnick]
 644     foreach ary $nick_arys {
 645         upvar #0 nick_${ary}($luser) old
 646         upvar #0 nick_${ary}($lusernew) new
 647         if {[info exists new]} { error "nick collision ?! $ary $n $newnick" }
 648         if {[info exists old]} { set new $old; unset old }
 649     }
 650     upvar #0 nick_onchans($lusernew) oc
 651     foreach ch $oc {
 652         upvar #0 chan_nicks($ch) nlist
 653         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 654         lappend nlist $lusernew
 655     }
 656     lnick_marktime_start $lusernew "Hi." 500 1
 657     nick_case $newnick
 658 }
 659
 660 proc nick_ishere {n} {
 661     global nick_counter
 662     upvar #0 nick_unique([irctolower $n]) u
 663     if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] }
 664     nick_case $n
 665 }
 666
 667 proc msg_JOIN {p c chan} {
 668     prefix_nick
 669     nick_ishere $n
 670     recordlastseen_n $n "joining $chan" 1
 671     set nl [irctolower $n]
 672     set lchan [irctolower $chan]
 673     upvar #0 nick_onchans($nl) oc
 674     upvar #0 chan_nicks($lchan) nlist
 675     if {![info exists oc]} {
 676         global marktime_join_startdelay
 677         lnick_marktime_start $nl "Welcome." $marktime_join_startdelay 1
 678     }
 679     lappend oc $lchan
 680     lappend nlist $nl
 681 }
 682 proc msg_PART {p c chan args} {
 683     prefix_nick
 684     set msg "leaving $chan"
 685     if {[llength $args]} {
 686         set why [lindex $args 0]
 687         if {"[irctolower $why]" != "[irctolower $n]"} { append msg " ($why)" }
 688     }
 689     recordlastseen_n $n $msg 1
 690     process_kickpart $chan $n
 691 }
 692 proc msg_QUIT {p c why} {
 693     prefix_nick
 694     recordlastseen_n $n "leaving ($why)" 0
 695     nick_forget $n
 696 }
 697
 698 proc msg_PRIVMSG {p c dest text} {
 699     global errorCode
 700
 701     prefix_nick
 702     if {[ischan $dest]} {
 703         recordlastseen_n $n "invoking me in $dest" 1
 704         set output $dest
 705     } else {
 706         recordlastseen_n $n "talking to me" 1
 707         set output $n
 708     }
 709     nick_case $n
 710
 711     execute_usercommand $p $c $n $output $dest $text
 712 }
 713
 714 proc msg_INVITE {p c n chan} {
 715     after 1000 [list dojoin [irctolower $chan]]
 716 }
 717
 718 proc grep {var predicate list} {
 719     set o {}
 720     upvar 1 $var v
 721     foreach v $list {
 722         if {[uplevel 1 [list expr $predicate]]} { lappend o $v }
 723     }
 724     return $o
 725 }
 726
 727 proc msg_353 {p c dest type chan nicklist} {
 728     global names_chans nick_onchans
 729     set lchan [irctolower $chan]
 730     upvar #0 chan_nicks($lchan) nlist
 731     lappend names_chans $lchan
 732     if {![info exists nlist]} {
 733         # We don't think we're on this channel, so ignore it !
 734         # Unfortunately, because we don't get a reply to PART,
 735         # we have to remember ourselves whether we're on a channel,
 736         # and ignore stuff if we're not, to avoid races.  Feh.
 737         return
 738     }
 739     set nlist_new {}
 740     foreach user [split $nicklist { }] {
 741         regsub {^[@+]} $user {} user
 742         if {![string length $user]} continue
 743         check_nick $user
 744         set luser [irctolower $user]
 745         upvar #0 nick_onchans($luser) oc
 746         lappend oc $lchan
 747         lappend nlist_new $luser
 748         nick_ishere $user
 749     }
 750     set nlist $nlist_new
 751 }
 752
 753 proc msg_366 {p c args} {
 754     global names_chans nick_onchans
 755     set lchan [irctolower $c]
 756     foreach luser [array names nick_onchans] {
 757         upvar #0 nick_onchans($luser) oc
 758         if {[llength names_chans] > 1} {
 759             set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc]
 760         }
 761         if {![llength $oc]} { lnick_forget $n }
 762     }
 763     unset names_chans
 764 }
 765
 766 proc check_username {target} {
 767     if {
 768         [string length $target] > 8 ||
 769         [regexp {[^-0-9a-z]} $target] ||
 770         ![regexp {^[a-z]} $target]
 771     } { error "invalid username" }
 772 }
 773
 774 proc somedb__head {} {
 775     uplevel 1 {
 776         set idl [irctolower $id]
 777         upvar #0 ${nickchan}db($idl) ndbe
 778         binary scan $idl H* idh
 779         set idfn $fprefix$idh
 780         if {![info exists iddbe] && [file exists $idfn]} {
 781             set f [open $idfn r]
 782             try_except_finally { set newval [read $f] } {} { close $f }
 783             if {[llength $newval] % 2} { error "invalid length" }
 784             set iddbe $newval
 785         }
 786     }
 787 }
 788
 789 proc def_somedb {name arglist body} {
 790     foreach {nickchan fprefix} {
 791         nick users/n
 792         chan chans/c
 793         msgs users/m
 794     } {
 795         proc ${nickchan}db_$name $arglist \
 796             "set nickchan $nickchan; set fprefix $fprefix; $body"
 797     }
 798 }
 799
 800 def_somedb list {} {
 801     set list {}
 802     foreach path [glob -nocomplain -path $fprefix *] {
 803         binary scan $path "A[string length $fprefix]A*" afprefix thinghex
 804         if {"$afprefix" != "$fprefix"} { error "wrong prefix $path $afprefix" }
 805         lappend list [binary format H* $thinghex]
 806     }
 807     return $list
 808 }
 809
 810 proc def_somedb_id {name arglist body} {
 811     def_somedb $name [concat id $arglist] "somedb__head; $body"
 812 }
 813
 814 def_somedb_id exists {} {
 815     return [info exists iddbe]
 816 }
 817
 818 def_somedb_id delete {} {
 819     catch { unset iddbe }
 820     file delete $idfn
 821 }
 822
 823 set default_settings_nick {
 824     timeformat ks
 825     marktime off
 826     tellsec {secure 600}
 827     tellrel {remind 3600 30}
 828 }
 829
 830 set default_settings_chan {
 831     autojoin 1
 832     mode *
 833     userinvite pub
 834     topicset {}
 835     topicsee {}
 836     topictell {}
 837 }
 838
 839 set default_settings_msgs {
 840     inbound {}
 841     outbound {}
 842 }
 843 # inbound -> [<nick> <time_t> <message>] ...
 844 # outbound -> [<nick> <time_t(earliest)> <count>] ...
 845 #   neither are sorted particularly; only one entry per recipient in
 846 #   output; both sender and recipient are cased
 847
 848 def_somedb_id set {args} {
 849     upvar #0 default_settings_$nickchan def
 850     if {![info exists iddbe]} { set iddbe $def }
 851     foreach {key value} [concat $iddbe $args] { set a($key) $value }
 852     set newval {}
 853     foreach {key value} [array get a] { lappend newval $key $value }
 854     set f [open $idfn.new w]
 855     try_except_finally {
 856         puts $f $newval
 857         close $f
 858         file rename -force $idfn.new $idfn
 859     } {
 860     } {
 861         catch { close $f }
 862     }
 863     set iddbe $newval
 864 }
 865
 866 def_somedb_id get {key} {
 867     upvar #0 default_settings_$nickchan def
 868     if {[info exists iddbe]} {
 869         set l [concat $iddbe $def]
 870     } else {
 871         set l $def
 872     }
 873     foreach {tkey value} $l {
 874         if {"$tkey" == "$key"} { return $value }
 875     }
 876     error "unset setting $key"
 877 }
 878
 879 proc opt {key} {
 880     global calling_nick
 881     if {[info exists calling_nick]} { set n $calling_nick } { set n {} }
 882     return [nickdb_get $n $key]
 883 }
 884
 885 proc check_notonchan {} {
 886     upvar 1 dest dest
 887     if {[ischan $dest]} { usererror "That command must be sent privately." }
 888 }
 889
 890 proc nick_securitycheck {strict} {
 891     upvar 1 n n
 892     if {![nickdb_exists $n]} {
 893         usererror "You are unknown to me, use `register'."
 894     }
 895     set wantu [nickdb_get $n username]
 896     if {![string length $wantu]} {
 897         if {$strict} {
 898             usererror "That feature is only available to secure users, sorry."
 899         } else {
 900             return
 901         }
 902     }
 903     set luser [irctolower $n]
 904     upvar #0 nick_username($luser) nu
 905     if {![info exists nu]} {
 906         usererror "Nick $n is secure, you must identify yourself first."
 907     }
 908     if {"$wantu" != "$nu"} {
 909         usererror "You are the wrong user -\
 910                 the nick $n belongs to $wantu, not $nu."
 911     }
 912 }
 913
 914 proc channel_ismanager {channel n} {
 915     set mgrs [chandb_get $channel managers]
 916     return [expr {[lsearch -exact [irctolower $mgrs] [irctolower $n]] >= 0}]
 917 }
 918
 919 proc channel_securitycheck {channel} {
 920     upvar n n
 921     if {![channel_ismanager $channel $n]} {
 922         usererror "You are not a manager of $channel."
 923     }
 924     nick_securitycheck 1
 925 }
 926
 927 proc def_chancmd {name body} {
 928     proc channel/$name {} \
 929             "    upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body"
 930 }
 931
 932 proc ta_listop {findnow procvalue} {
 933     # findnow and procvalue are code fragments which will be executed
 934     # in the caller's level.  findnow should set ta_listop_ev to
 935     # the current list, and procvalue should treat ta_listop_ev as
 936     # a proposed value in the list and check and possibly modify
 937     # (canonicalise?) it.  After ta_listop, ta_listop_ev will
 938     # be the new value of the list.
 939     upvar 1 ta_listop_ev exchg
 940     upvar 1 text text
 941     set opcode [ta_word]
 942     switch -exact _$opcode {
 943         _= { }
 944         _+ - _- {
 945             uplevel 1 $findnow
 946             foreach item $exchg { set array($item) 1 }
 947         }
 948         default {
 949             error "list change opcode must be one of + - ="
 950         }
 951     }
 952     foreach exchg [split $text " "] {
 953         if {![string length $exchg]} continue
 954         uplevel 1 $procvalue
 955         if {"$opcode" != "-"} {
 956             set array($exchg) 1
 957         } else {
 958             catch { unset array($exchg) }
 959         }
 960     }
 961     set exchg [lsort [array names array]]
 962 }
 963
 964 def_chancmd manager {
 965     ta_listop {
 966         if {[chandb_exists $chan]} {
 967             set ta_listop_ev [chandb_get $chan managers]
 968         } else {
 969             set ta_listop_ev [list [irctolower $n]]
 970         }
 971     } {
 972         check_nick $ta_listop_ev
 973         set ta_listop_ev [irctolower $ta_listop_ev]
 974     }
 975     if {[llength $ta_listop_ev]} {
 976         chandb_set $chan managers $ta_listop_ev
 977         ucmdr "Managers of $chan: $ta_listop_ev" {}
 978     } else {
 979         chandb_delete $chan
 980         ucmdr {} {} "forgets about managing $chan." {}
 981     }
 982 }
 983
 984 def_chancmd autojoin {
 985     set yesno [ta_word]
 986     switch -exact [string tolower $yesno] {
 987         no { set nv 0 }
 988         yes { set nv 1 }
 989         default { error "channel autojoin must be `yes' or `no' }
 990     }
 991     chandb_set $chan autojoin $nv
 992     ucmdr [expr {$nv ? "I will join $chan when I'm restarted " : \
 993             "I won't join $chan when I'm restarted "}] {}
 994 }
 995
 996 def_chancmd userinvite {
 997     set nv [string tolower [ta_word]]
 998     switch -exact $nv {
 999         pub { set txt "!invite will work for $chan, but it won't work by /msg" }
1000         here { set txt "!invite and /msg invite will work, but only for users who are already on $chan." }
1001         all { set txt "Any user will be able to invite themselves or anyone else to $chan." }
1002         none { set txt "I will not invite anyone to $chan." }
1003         default {
1004             error "channel userinvite must be `pub', `here', `all' or `none'
1005         }
1006     }
1007     chandb_set $chan userinvite $nv
1008     ucmdr $txt {}
1009 }
1010
1011 def_chancmd topic {
1012     set what [ta_word]
1013     switch -exact $what {
1014         leave {
1015             ta_nomore
1016             chandb_set $chan topicset {}
1017             ucmdr "I won't ever change the topic of $chan." {}
1018         }
1019         set {
1020             set t [string trim $text]
1021             if {![string length $t]} {
1022                 error "you must specific the topic to set"
1023             }
1024             chandb_set $chan topicset $t
1025             ucmdr "Whenever I'm alone on $chan, I'll set the topic to $t." {}
1026         }
1027         see - tell {
1028             ta_listop {
1029                 set ta_listop_ev [chandb_get $chan topic$what]
1030             } {
1031                 if {"$ta_listop_ev" != "*"} {
1032                     if {![ischan $ta_listop_ev]} {
1033                         error "bad channel \`$ta_listop_ev' in topic $what"
1034                     }
1035                     set ta_listop_ev [irctolower $ta_listop_ev]
1036                 }
1037             }
1038             chandb_set $chan topic$what $ta_listop_ev
1039             ucmdr "Topic $what list for $chan: $ta_listop_ev" {}
1040         }
1041         default {
1042             usererror "Unknown channel topic subcommand - see help channel."
1043         }
1044     }
1045 }
1046
1047 def_chancmd mode {
1048     set mode [ta_word]
1049     if {"$mode" != "*" && ![regexp {^(([-+][imnpst]+)+)$} $mode mode]} {
1050         error {channel mode must be * or match ([-+][imnpst]+)+}
1051     }
1052     chandb_set $chan mode $mode
1053     if {"$mode" == "*"} {
1054         ucmdr "I won't ever change the mode of $chan." {}
1055     } else {
1056         ucmdr "Whenever I'm alone on $chan, I'll set the mode to $mode." {}
1057     }
1058 }
1059
1060 def_chancmd show {
1061     if {[chandb_exists $chan]} {
1062         set l "Settings for $chan: autojoin "
1063         append l [lindex {no yes} [chandb_get $chan autojoin]]
1064         append l ", mode " [chandb_get $chan mode]
1065         append l ", userinvite " [chandb_get $chan userinvite] "."
1066         append l "\nManagers: "
1067         append l [join [chandb_get $chan managers] " "]
1068         foreach {ts sep} {see "\n" tell "  "} {
1069             set t [chandb_get $chan topic$ts]
1070             append l $sep
1071             if {[llength $t]} {
1072                 append l "Topic $ts list: $t."
1073             } else {
1074                 append l "Topic $ts list is empty."
1075             }
1076         }
1077         append l "\n"
1078         set t [chandb_get $chan topicset]
1079         if {[string length $t]} {
1080             append l "Topic to set: $t"
1081         } else {
1082             append l "I will not change the topic."
1083         }
1084         ucmdr {} $l
1085     } else {
1086         ucmdr {} "The channel $chan is not managed."
1087     }
1088 }
1089
1090 proc channelmgr_monoop {} {
1091     upvar 1 dest dest
1092     upvar 1 text text
1093     upvar 1 n n
1094     upvar 1 p p
1095     upvar 1 target target
1096     global chan_nicks
1097
1098     prefix_nick
1099
1100     if {[ischan $dest]} { set target $dest }
1101     if {[ta_anymore]} { set target [ta_word] }
1102     ta_nomore
1103     if {![info exists target]} {
1104         usererror "You must specify, or invoke me on, the relevant channel."
1105     }
1106     if {![info exists chan_nicks([irctolower $target])]} {
1107         usererror "I am not on $target."
1108     }
1109     if {![ischan $target]} { error "not a valid channel" }
1110
1111     if {![chandb_exists $target]} {
1112         usererror "$target is not a managed channel."
1113     }
1114     channel_securitycheck $target
1115 }
1116
1117 def_ucmd op {
1118     channelmgr_monoop
1119     sendout MODE $target +o $n
1120 }
1121
1122 def_ucmd leave {
1123     channelmgr_monoop
1124     doleave $target
1125 }
1126
1127 def_ucmd invite {
1128     global chan_nicks errorCode errorInfo
1129     prefix_nick
1130
1131     if {[ischan $dest]} {
1132         set target $dest
1133         set onchan 1
1134     } else {
1135         set target [ta_word]
1136         set onchan 0
1137     }
1138     set ltarget [irctolower $target]
1139     if {![ischan $target]} { error "$target is not a channel" }
1140     if {![info exists chan_nicks($ltarget)]} {
1141         usererror "I am not on $target."
1142     }
1143     set ui [chandb_get $ltarget userinvite]
1144     if {[catch {
1145         if {"$ui" == "pub" && !$onchan} {
1146             usererror "Invitations to $target must be made there with !invite."
1147         }
1148         if {"$ui" != "all"} {
1149             if {[lsearch -exact $chan_nicks($ltarget) [irctolower $n]] < 0} {
1150                 usererror "Invitations to $target may only be made\
1151                         by a user on the channel."
1152             }
1153         }
1154         if {"$ui" == "none"} {
1155             usererror "Sorry, I've not been authorised\
1156                     to invite people to $target."
1157         }
1158     } emsg]} {
1159         if {"$errorCode" == "BLIGHT USER" && [channel_ismanager $target $n]} {
1160             if {[catch {
1161                 nick_securitycheck 1
1162             } emsg2]} {
1163                 if {"$errorCode" == "BLIGHT USER"} {
1164                     usererror "$emsg2  Therefore you can't use your\
1165                             channel manager privilege.  $emsg"
1166                 } else {
1167                     error $error $errorInfo $errorCode
1168                 }
1169             }
1170         } else {
1171             error $emsg $errorInfo $errorCode
1172         }
1173     }
1174     if {![ta_anymore]} {
1175         usererror "You have to say who to invite."
1176     }
1177     set invitees {}
1178     while {[ta_anymore]} {
1179         set invitee [ta_nick]
1180         lappend invitees $invitee
1181     }
1182     foreach invitee $invitees {
1183         sendout INVITE $invitee $ltarget
1184     }
1185     set who [lindex $invitees 0]
1186     switch -exact llength $invitees {
1187         0 { error "zero invitees" }
1188         1 { }
1189         2 { append who " and [lindex $invitees 1]" }
1190         * {
1191             set who [join [lreplace $invitees end end] ", "]
1192             append who " and [lindex $invitees [llength $invitees]]"
1193         }
1194     }
1195     ucmdr {} {} {} "invites $who to $target."
1196 }
1197
1198 def_ucmd channel {
1199     if {[ischan $dest]} { set target $dest }
1200     if {![ta_anymore]} {
1201         set subcmd show
1202     } else {
1203         set subcmd [ta_word]
1204     }
1205     if {[ischan $subcmd]} {
1206         set target $subcmd
1207         if {![ta_anymore]} {
1208             set subcmd show
1209         } else {
1210             set subcmd [ta_word]
1211         }
1212     }
1213     if {![info exists target]} { error "privately, you must specify a channel" }
1214     set procname channel/$subcmd
1215     if {"$subcmd" != "show"} {
1216         if {[catch { info body $procname }]} {
1217             usererror "unknown channel setting $subcmd."
1218         }
1219         prefix_nick
1220         if {[chandb_exists $target]} {
1221             channel_securitycheck $target
1222         } else {
1223             nick_securitycheck 1
1224             upvar #0 chan_initialop([irctolower $target]) io
1225             upvar #0 nick_unique([irctolower $n]) u
1226             if {![info exists io]} {
1227                 usererror "$target is not a managed channel."
1228             }
1229             if {"$io" != "$u"} {
1230                 usererror "You are not the interim manager of $target."
1231             }
1232             if {"$subcmd" != "manager"} {
1233                 usererror "Please use `channel manager' first."
1234             }
1235         }
1236     }
1237     channel/$subcmd
1238 }
1239
1240 proc nickdb_get_username {n} {
1241     if {![nickdb_exists $n]} { return "" }
1242     return [nickdb_get $n username]
1243 }
1244
1245 proc nickdb_get_sec_effective {n} {
1246     set l [nickdb_get $n tellsec]
1247     set u [nickdb_get_username $n]
1248     if {"[lindex $l 0]" == "secure" && ![string length $u]} { set l insecure }
1249     return $l
1250 }
1251
1252 proc tell_peernicks {text} {
1253     global errorInfo errorCode
1254     set text [irctolower [string trim $text]]
1255     set senders [split $text " "]
1256     foreach sender $senders {
1257         if {[catch { check_nick $sender } emsg]} {
1258             error "invalid nick `$sender': $emsg" $errorInfo $errorCode
1259         }
1260     }
1261     return $senders
1262 }
1263
1264 proc msgsdb_set_maydelete {n key l otherkey} {
1265     msgsdb_set $n $key $l
1266     if {[llength $l]} return
1267     if {[llength [msgsdb_get $n $otherkey]]} return
1268     msgsdb_delete $n
1269 }
1270
1271 proc tell_delete_msgs {lsenders lrecip} {
1272     set ninbound {}
1273     set ndel 0
1274     foreach {s t m} [msgsdb_get $lrecip inbound] {
1275         if {[llength $lsenders]} {
1276             if {[lsearch -exact $lsenders [irctolower $s]] == -1} {
1277                 lappend ninbound $s $t $m
1278                 continue
1279             }
1280         }
1281         set rsenders($s) 1
1282         incr ndel
1283     }
1284     msgsdb_set_maydelete $lrecip inbound $ninbound outbound
1285     if {![llength $ninbound]} {
1286         upvar #0 nick_telling($lrecip) telling
1287         catch { unset telling }
1288     }
1289     foreach s [array names rsenders] {
1290         set noutbound {}
1291         foreach {r t c} [msgsdb_get $s outbound] {
1292             if {"[irctolower $r]" == "$lrecip"} continue
1293             lappend noutbound $r $t $c
1294         }
1295         msgsdb_set_maydelete $s outbound $noutbound inbound
1296     }
1297     return $ndel
1298 }
1299
1300 def_ucmd untell {
1301     prefix_nick
1302     check_notonchan
1303     nick_securitycheck 0
1304     set recipients [tell_peernicks $text]
1305     if {![llength $recipients]} {
1306         usererror "You must say which recipients' messages from you to forget."
1307     }
1308     set ndel 0
1309     foreach recip $recipients {
1310         incr ndel [tell_delete_msgs [irctolower $n] $recip]
1311     }
1312     ucmdr "Removed $ndel as yet undelivered message(s)." {}
1313 }
1314
1315 def_ucmd delmsg {
1316     global errorInfo errorCode
1317     prefix_nick
1318     set nl [irctolower $n]
1319     check_notonchan
1320     manyset [nickdb_get_sec_effective $n] sec secwhen
1321     switch -exact $sec {
1322         insecure { }
1323         refuse - mailto {
1324             usererror \
1325  "There are no messages to delete\
1326  because your message disposition prevents them from being left."
1327         }
1328         secure {
1329             nick_securitycheck 1
1330         }
1331         default {
1332             error "delmsg sec $sec"
1333         }
1334     }
1335     if {![llength [msgsdb_get $n inbound]]} {
1336         ucmdr "No incoming messages to delete." {}
1337     }
1338     tell_getcstate
1339     if {![info exists u]} {
1340         usererror \
1341  "I can't delete your messages unless I can see you on a channel with me.\
1342   Otherwise I might delete a message I hadn't told you about yet."
1343     }
1344     if {"$stt" != "passed"} {
1345         set telling [list $u undelivered 0]
1346         usererror \
1347  "There are message(s) you may not yet have seen;\
1348  I'll deliver them to you now.\
1349   If you actually want to delete them, just tell me `delmsg' again."
1350     }
1351     set senders [tell_peernicks $text]
1352     set ndel [tell_delete_msgs [irctolower $senders] [irctolower $n]]
1353     if {!$ndel} {
1354         if {[llength $senders]} {
1355             ucmdr "No relevant incoming messages to delete." {}
1356         }
1357     }
1358     switch -exact [llength $senders] {
1359         0 { ucmdr {} {} "deletes your $ndel message(s)." }
1360         1 { ucmdr {} {} "deletes your $ndel message(s) from $senders." }
1361         default {
1362             ucmdr {} {} "deletes your $ndel message(s) from\
1363  [lreplace $senders end end] and [lindex $senders end]."
1364         }
1365     }
1366 }
1367
1368 def_ucmd tellme {
1369     prefix_nick
1370     ta_nomore
1371     check_notonchan
1372     switch -exact [tell_event [irctolower $n] tellme] {
1373         ERROR - INVALID { ucmdr {} {is ill.  Help!} }
1374         nomsgs { ucmdr {You have no messages.} {} }
1375         default { }
1376     }
1377 }
1378
1379 def_ucmd tell {
1380     global nick_case ownmailaddr ownfullname
1381
1382     prefix_nick
1383     set target [ta_nick]
1384     if {![string length $text]} { error "tell them what?" }
1385     if {[string length $text] > 400} { error "message too long" }
1386
1387     set ltarget [irctolower $target]
1388     set ctarget $target
1389     if {[info exists nick_case($ltarget)]} { set ctarget $nick_case($ltarget) }
1390
1391     manyset [nickdb_get_sec_effective $target] sec mailtoint mailwhy
1392     manyset [nickdb_get $target tellrel] rel relint relwithin
1393     switch -exact $sec {
1394         insecure - secure {
1395             set now [clock seconds]
1396             set inbound [msgsdb_get $ltarget inbound]
1397             lappend inbound $n $now $text
1398             msgsdb_set $ltarget inbound $inbound
1399
1400             set outbound [msgsdb_get $n outbound]
1401             set noutbound {}
1402             set found 0
1403             foreach {recip time count} $outbound {
1404                 if {"[irctolower $recip]" == "$ltarget"} {
1405                     incr count
1406                     set recip $ctarget
1407                     set found 1
1408                 }
1409                 lappend noutbound $recip $time $count
1410             }
1411             if {!$found} {
1412                 lappend noutbound $ctarget $now 1
1413             }
1414             msgsdb_set $n outbound $noutbound
1415             set msg "OK, I'll tell $ctarget"
1416             if {$found} { append msg " that too" }
1417             append msg ", "
1418             if {"$sec" != "secure"} {
1419                 switch -exact $rel {
1420                     unreliable { append msg "neither reliably nor securely" }
1421                     remind { append msg "pretty reliably, but not securely" }
1422                     pester { append msg "reliably but not securely" }
1423                 }
1424             } else {
1425                 switch -exact $rel {
1426                     unreliable { append msg "securely but not reliably" }
1427                     remind { append msg "securely and pretty reliably" }
1428                     pester { append msg "reliably and securely" }
1429                 }
1430             }
1431             append msg .
1432             tell_event $ltarget msgsarrive
1433             ucmdr $msg {}
1434         }
1435         mailto {
1436             set fmtmsg [exec fmt << " $text"]
1437             exec /usr/sbin/sendmail -odb -oi -t -oee -f $mailwhy \
1438                     > /dev/null << \
1439  "From: $ownmailaddr ($ownfullname)
1440 To: $mailtoint
1441 Subject: IRC tell from $n
1442
1443 $n asked me[expr {[ischan $dest] ? " on $dest" : ""}] to tell you:
1444 [exec fmt << " $text"]
1445
1446 (This message was for your nick $ctarget; your account $mailwhy
1447  arranged for it to be forwarded to $mailtoint.)
1448 "
1449             ucmdr \
1450  "I've mailed $ctarget, which is what they prefer." \
1451                 {}
1452         }
1453         refuse {
1454             usererror "Sorry, $ctarget does not want me to take messages."
1455         }
1456         default {
1457             error "bad tellsec $sec"
1458         }
1459     }
1460 }
1461
1462 def_ucmd who {
1463     if {[ta_anymore]} {
1464         set target [ta_nick]; ta_nomore
1465         set myself 1
1466     } else {
1467         prefix_nick
1468         set target $n
1469         set myself [expr {"$target" != "$n"}]
1470     }
1471     set ltarget [irctolower $target]
1472     upvar #0 nick_case($ltarget) ctarget
1473     set nshow $target
1474     if {[info exists ctarget]} {
1475         upvar #0 nick_onchans($ltarget) oc
1476         upvar #0 nick_username($ltarget) nu
1477         if {[info exists oc]} { set nshow $ctarget }
1478     }
1479     if {![nickdb_exists $ltarget]} {
1480         set ol "$nshow is not a registered nick."
1481     } elseif {[string length [set username [nickdb_get $target username]]]} {
1482         set ol "The nick $nshow belongs to the user $username."
1483     } else {
1484         set ol "The nick $nshow is registered (but not to a username)."
1485     }
1486     if {![info exists ctarget] || ![info exists oc]} {
1487         if {$myself} {
1488             append ol "\nI can't see $nshow on anywhere."
1489         } else {
1490             append ol "\nYou aren't on any channels with me."
1491         }
1492     } elseif {![info exists nu]} {
1493         append ol "\n$nshow has not identified themselves."
1494     } elseif {![info exists username]} {
1495         append ol "\n$nshow has identified themselves as the user $nu."
1496     } elseif {"$nu" != "$username"} {
1497         append ol "\nHowever, $nshow is being used by the user $nu."
1498     } else {
1499         append ol "\n$nshow has identified themselves to me."
1500     }
1501     ucmdr {} $ol
1502 }
1503
1504 def_ucmd register {
1505     prefix_nick
1506     check_notonchan
1507     set old [nickdb_exists $n]
1508     if {$old} { nick_securitycheck 0 }
1509     set luser [irctolower $n]
1510     switch -exact [string tolower [string trim $text]] {
1511         {} {
1512             upvar #0 nick_username($luser) nu
1513             if {![info exists nu]} {
1514                 ucmdr {} \
1515  "You must identify yourself before using `register'.  See `help identify', or use `register insecure'."
1516             }
1517             nickdb_set $n username $nu
1518             ucmdr {} {} "makes a note of your username." {}
1519         }
1520         delete {
1521             nickdb_delete $n
1522             ucmdr {} {} "forgets your nickname." {}
1523         }
1524         insecure {
1525             nickdb_set $n username {}
1526             if {$old} {
1527                 ucmdr {} "Security is now disabled for your nickname !"
1528             } else {
1529                 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."
1530             }
1531         }
1532         default {
1533             error "you mean register / register delete / register insecure"
1534         }
1535     }
1536 }
1537
1538 proc timeformat_desc {tf} {
1539     switch -exact $tf {
1540         ks { return "Times will be displayed in seconds or kiloseconds." }
1541         hms { return "Times will be displayed in hours, minutes, etc." }
1542         default { error "invalid timeformat: $v" }
1543     }
1544 }
1545
1546 set settings {}
1547 proc def_setting {opt show_body set_body} {
1548     global settings
1549     lappend settings $opt
1550     proc set_show/$opt {} "
1551         upvar 1 n n
1552         set opt $opt
1553         $show_body"
1554     if {![string length $set_body]} return
1555     proc set_set/$opt {} "
1556         upvar 1 n n
1557         upvar 1 text text
1558         set opt $opt
1559         $set_body"
1560 }
1561
1562 proc tellme_sec_desc {v n} {
1563     manyset $v sec mailtoint
1564     switch -exact $sec {
1565         insecure {
1566             return "I'll tell you your messages whenever I see you."
1567         }
1568         secure {
1569             if {[string length [nickdb_get_username $n]]} {
1570                 return \
1571  "I'll keep the bodies of your messages private until you identify yourself, reminding you every [showintervalsecs $mailtoint 1]."
1572             } else {
1573                 return \
1574  "I'll tell you your messages whenever I see you.\
1575   (Secure message delivery is enabled, but your nick is not registered\
1576  securely.  See `help register'.)"
1577             }
1578         }
1579         refuse {
1580             return "I shan't accept messages for you."
1581         }
1582         mailto {
1583             return "I'll forward your messages by email to $mailtoint."
1584         }
1585         default {
1586             error "bad tellsec $sec"
1587         }
1588     }
1589 }
1590
1591 proc tellme_rel_desc {v n} {
1592     manyset $v rel every within
1593     switch -exact $rel {
1594         unreliable {
1595             return "As soon as I've told you message(s), I'll forget them\
1596  - note that this means messages can get lost !"
1597         }
1598         pester {
1599             set u {}
1600         }
1601         remind {
1602             set u ", or talk on channel within [showintervalsecs $within 1] of me having told you"
1603         }
1604         default {
1605             error "bad tellrel $rel"
1606         }
1607     }
1608     return "After delivering messages, I'll remind you every\
1609  [showintervalsecs $every 1] until you say delmsg$u."
1610 }
1611
1612 def_setting timeformat {
1613     set tf [nickdb_get $n timeformat]
1614     return "$tf: [timeformat_desc $tf]"
1615 } {
1616     set tf [string tolower [ta_word]]
1617     ta_nomore
1618     set desc [timeformat_desc $tf]
1619     nickdb_set $n timeformat $tf
1620     ucmdr {} $desc
1621 }
1622
1623 proc marktime_desc {mt} {
1624     if {"$mt" == "off"} {
1625         return "I will not send you periodic messages."
1626     } elseif {"$mt" == "once"} {
1627         return "I will send you one informational message when I see you."
1628     } else {
1629         return "I'll send you a message every [showintervalsecs $mt 0]."
1630     }
1631 }
1632
1633 def_setting marktime {
1634     set mt [nickdb_get $n marktime]
1635     set p $mt
1636     if {[string match {[0-9]*} $mt]} { append p s }
1637     append p ": "
1638     append p [marktime_desc $mt]
1639     return $p
1640 } {
1641     global marktime_min
1642     set mt [string tolower [ta_word]]
1643     ta_nomore
1644
1645     if {"$mt" == "off" || "$mt" == "once"} {
1646     } else {
1647         set mt [parse_interval $mt $marktime_min]
1648     }
1649     nickdb_set $n marktime $mt
1650     lnick_marktime_start [irctolower $n] "So:" 500 0
1651     ucmdr {} [marktime_desc $mt]
1652 }
1653
1654 def_setting security {
1655     set s [nickdb_get $n username]
1656     if {[string length $s]} {
1657         return "Your nick, $n, is controlled by the user $s."
1658     } else {
1659         return "Your nick, $n, is not secure."
1660     }
1661 } {}
1662
1663 proc tellme_setting_sec_simple {} {
1664     uplevel 1 {
1665         ta_nomore
1666         set sr sec
1667         set v $setting
1668     }
1669 }
1670
1671 proc tellme_setting_neednomsgs {} {
1672     uplevel 1 {
1673         if {[llength [msgsdb_get $n inbound]]} {
1674             usererror "You must delete the incoming messages you have, first."
1675         }
1676     }
1677 }
1678
1679 def_setting tellme {
1680     set secv [nickdb_get $n tellsec]
1681     set ms [tellme_sec_desc $secv $n]
1682     manyset $secv sec
1683     switch -exact $sec {
1684         insecure - secure {
1685             set mr [tellme_rel_desc [nickdb_get $n tellrel] $n]
1686             return "$ms  $mr"
1687         }
1688         refuse - mailto {
1689             return $ms
1690         }
1691     }
1692 } {
1693     set setting [string tolower [ta_word]]
1694     switch -exact $setting {
1695         insecure {
1696             tellme_setting_sec_simple
1697         }
1698         secure {
1699             set every [ta_interval_optional 60 600]
1700             ta_nomore
1701             set sr sec
1702             set v [list secure $every]
1703         }
1704         refuse {
1705             tellme_setting_neednomsgs
1706             tellme_setting_sec_simple
1707         }
1708         mailto {
1709             tellme_setting_neednomsgs
1710
1711             if {![string length [set u [nickdb_get_username $n]]]} {
1712                 usererror \
1713  "Sorry, you must register securely to have your messages mailed\
1714  (to prevent the use of this feature for spamming).  See `help register'."
1715             }
1716             set sr sec
1717             set v [list mailto [ta_word] $u]
1718         }
1719         unreliable - pester - remind {
1720             manyset [nickdb_get $n tellsec] sec
1721             switch -exact $sec {
1722                 refuse - mailto {
1723                     usererror \
1724  "You can't change your message delivery conditions when\
1725  your message disposition prevents messages from being left."
1726                 }
1727             }
1728             set sr rel
1729             set v $setting
1730             if {"$setting" != "unreliable"} {
1731                 set every [ta_interval_optional 300 3600]
1732                 lappend v $every
1733             }
1734             if {"$setting" == "remind"} {
1735                 set within [ta_interval_optional 5 30]
1736                 if {$within > $every} {
1737                     error "remind interval must be at least time to respond"
1738                 }
1739                 lappend v $within
1740             }
1741             ta_nomore
1742         }
1743         default {
1744             error "invalid tellme setting $setting"
1745         }
1746     }
1747     nickdb_set $n tell$sr $v
1748     upvar #0 nick_telling([irctolower $n]) telling
1749     catch { unset telling }
1750     ucmdr [tellme_${sr}_desc $v $n] {}
1751 }
1752
1753 proc lnick_checktold {luser} {
1754     set ml [msgsdb_get $luser outbound]
1755     if {![llength $ml]} return
1756     set is1 [expr {[llength $ml]==3}]
1757     set m1 "FYI, I haven't yet delivered your"
1758     set ol {}
1759     set now [clock seconds]
1760     while {[llength $ml]} {
1761         manyset $ml r t n
1762         set ml [lreplace $ml 0 2]
1763         set td [expr {$now-$t}]
1764         if {$n == 1} {
1765             set iv [showinterval $td]
1766             set ifo "$r, $iv"
1767             set if1 "message to $r, $iv."
1768         } else {
1769             set iv [showintervalsecs $td 0]
1770             set ifo "$r, $n messages, oldest $iv"
1771             set if1 "$n messages to $r, oldest $iv."
1772         }
1773         if {$is1} {
1774             sendprivmsg $luser "$m1 $if1"
1775             return
1776         } else {
1777             lappend ol " to $ifo[expr {[llength $ml] ? ";" : "."}]"
1778         }
1779     }
1780     sendprivmsg $luser "$m1 messages:"
1781     msendprivmsg $luser $ol
1782 }
1783
1784 def_ucmd set {
1785     global settings
1786     prefix_nick
1787     check_notonchan
1788     if {![nickdb_exists $n]} {
1789         ucmdr {} "You are unknown to me and so have no settings.  (Use `register'.)"
1790     }
1791     if {![ta_anymore]} {
1792         set ol {}
1793         foreach opt $settings {
1794             lappend ol [format "%-10s %s" $opt [set_show/$opt]]
1795         }
1796         ucmdr {} [join $ol "\n"]
1797     } else {
1798         set opt [ta_word]
1799         if {[catch { info body set_show/$opt }]} {
1800             error "no setting $opt"
1801         }
1802         if {![ta_anymore]} {
1803             ucmdr {} "$opt: [set_show/$opt]"
1804         } else {
1805             nick_securitycheck 0
1806             if {[catch { info body set_set/$opt }]} {
1807                 error "setting $opt cannot be set with `set'"
1808             }
1809             set_set/$opt
1810         }
1811     }
1812 }
1813
1814 def_ucmd identpass {
1815     prefix_nick
1816     check_notonchan
1817     set luser [irctolower $n]
1818     set username [ta_word]
1819     set passmd5 [md5sum "[ta_word]\n"]
1820     ta_nomore
1821     upvar #0 nick_onchans($luser) onchans
1822     if {![info exists onchans] || ![llength $onchans]} {
1823         ucmdr "You must be on a channel with me to identify yourself." {}
1824     }
1825     check_username $username
1826     exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \
1827             irc-identpass $n
1828     upvar #0 nick_username($luser) rec_username
1829     set rec_username $username
1830     after 50 [list tell_event $luser ident]
1831     ucmdr "Pleased to see you, $username." {}
1832 }
1833
1834 def_ucmd summon {
1835     set target [ta_word]
1836     ta_nomore
1837     check_username $target
1838     prefix_nick
1839
1840     upvar #0 lastsummon($target) ls
1841     set now [clock seconds]
1842     if {[info exists ls]} {
1843         set interval [expr {$now - $ls}]
1844         if {$interval < 30} {
1845             ucmdr {} \
1846  "Please be patient; $target was summoned only [showinterval $interval]."
1847         }
1848     }
1849     regsub {^[^!]*!} $p {} path
1850     if {[catch {
1851         exec userv --timeout 3 $target irc-summon $n $path \
1852                 [expr {[ischan $dest] ? "$dest" : ""}] \
1853                 < /dev/null
1854     } rv]} {
1855         regsub -all "\n" $rv { / } rv
1856         error $rv
1857     }
1858     if {[regexp {^problem (.*)} $rv dummy problem]} {
1859         ucmdr {} "The user `$target' $problem."
1860     } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} {
1861         set idletime [expr {$now - $idlesince}]
1862         set ls $now
1863         ucmdr {} {} {} "invites $target ($tty[expr {
1864             $idletime > 10 ? ", idle for [showintervalsecs $idletime 0]" : ""
1865         }]) to [expr {
1866             [ischan $dest] ? "join us here" : "talk to you"
1867         }]."
1868     } else {
1869         error "unexpected response from userv service: $rv"
1870     }
1871 }
1872
1873 proc md5sum {value} { exec md5sum << $value }
1874
1875 def_ucmd seen {
1876     global lastseen nick
1877     prefix_nick
1878     set ncase [ta_nick]
1879     set nlower [irctolower $ncase]
1880     ta_nomore
1881     set now [clock seconds]
1882     if {"$nlower" == "[irctolower $nick]"} {
1883         usererror "I am not self-aware."
1884     } elseif {![info exists lastseen($nlower)]} {
1885         set rstr "I've never seen $ncase."
1886     } else {
1887         manyset $lastseen($nlower) realnick time what
1888         set howlong [expr {$now - $time}]
1889         set string [showinterval $howlong]
1890         set rstr "I last saw $realnick $string, $what."
1891     }
1892     if {[ischan $dest]} {
1893         set where $dest
1894     } else {
1895         set where {}
1896     }
1897     upvar #0 lookedfor($nlower) lf
1898     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
1899     set lf [list [list $now $n $where]]
1900     foreach v $oldvalue {
1901         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
1902         lappend lf $v
1903     }
1904     ucmdr {} $rstr
1905 }
1906
1907 proc lnick_marktime_cancel {luser} {
1908     upvar #0 nick_markid($luser) mi
1909     if {![info exists mi]} return
1910     catch { after cancel $mi }
1911     catch { unset mi }
1912 }
1913
1914 proc lnick_marktime_doafter {luser why ms mentiontold} {
1915     lnick_marktime_cancel $luser
1916     upvar #0 nick_markid($luser) mi
1917     set mi [after $ms [list lnick_marktime_now $luser $why 0]]
1918 }
1919
1920 proc lnick_marktime_reset {luser} {
1921     set mt [nickdb_get $luser marktime]
1922     if {"$mt" == "off" || "$mt" == "once"} return
1923     lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] 0
1924 }
1925
1926 proc lnick_marktime_start {luser why ms mentiontold} {
1927     set mt [nickdb_get $luser marktime]
1928     if {"$mt" == "off"} {
1929         lnick_marktime_cancel $luser
1930         if {$mentiontold} { after $ms [list lnick_checktold $luser] }
1931     } else {
1932         lnick_marktime_doafter $luser $why $ms $mentiontold
1933     }
1934 }
1935
1936 proc lnick_marktime_now {luser why mentiontold} {
1937     upvar #0 nick_onchans($luser) oc
1938     global calling_nick
1939     set calling_nick $luser
1940     sendprivmsg $luser [lnick_pingstring $why $oc ""]
1941     if {$mentiontold} { after 150 [list lnick_checktold $luser] }
1942     lnick_marktime_reset $luser
1943 }
1944
1945 proc lnick_pingstring {why oc apstring} {
1946     global nick_onchans
1947     catch { exec uptime } uptime
1948     set nnicks [llength [array names nick_onchans]]
1949     if {[regexp \
1950  {^ *([0-9:apm]+) +up.*, +(\d+) users?, +load average: +([0-9., ]+) *$} \
1951             $uptime dummy time users load]} {
1952         regsub -all , $load {} load
1953         set uptime "$time  $nnicks/$users  $load"
1954     } else {
1955         append uptime ", $nnicks nicks"
1956     }
1957     if {[llength $oc]} {
1958         set best_la 0
1959         set activity quiet
1960         foreach ch $oc {
1961             upvar #0 chan_lastactivity($ch) la
1962             if {![info exists la]} continue
1963             if {$la <= $best_la} continue
1964             set since [showintervalsecs [expr {[clock seconds]-$la}] 1]
1965             set activity "$ch $since"
1966             set best_la $la
1967         }
1968     } else {
1969         set activity unseen
1970     }
1971     set str $why
1972     append str "  " $uptime "  " $activity
1973     if {[string length $apstring]} { append str "  " $apstring }
1974     return $str
1975 }
1976
1977 def_ucmd ping {
1978     prefix_nick
1979     set ln [irctolower $n]
1980     if {[ischan $dest]} {
1981         set oc [irctolower $dest]
1982     } else {
1983         global nick_onchans
1984         if {[info exists nick_onchans($ln)]} {
1985             set oc $nick_onchans($ln)
1986         } else {
1987             set oc {}
1988         }
1989         if {[llength $oc]} { lnick_marktime_reset $ln }
1990     }
1991     after 150 [list lnick_checktold $ln]
1992     ucmdr {} [lnick_pingstring "Pong!" $oc $text]
1993 }
1994
1995 proc ensure_globalsecret {} {
1996     global globalsecret
1997
1998     if {[info exists globalsecret]} return
1999     set gsfile [open /dev/urandom r]
2000     fconfigure $gsfile -translation binary
2001     set globalsecret [read $gsfile 32]
2002     binary scan $globalsecret H* globalsecret
2003     close $gsfile
2004     unset gsfile
2005 }
2006
2007 proc connected {} {
2008     foreach chan [chandb_list] {
2009         if {[chandb_get $chan autojoin]} { dojoin $chan }
2010     }
2011 }
2012
2013 ensure_globalsecret
2014 loadhelp
2015 ensure_connecting