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 proc privmsg_unlogged {prefix ischan params} {
  10     if {!$ischan ||
  11         [regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} {
  12         return 0
  13     }
  14     # on-channel message, ignore
  15     set chan [lindex $params 0]
  16     upvar #0 chan_lastactivity([irctolower $chan]) la
  17     set la [clock seconds]
  18     catch { recordlastseen_p $prefix "talking on $chan" 1 }
  19     return 1
  20 }
  21
  22 proc showintervalsecs {howlong abbrev} {
  23     return [showintervalsecs/[opt timeformat] $howlong $abbrev]
  24 }
  25
  26 proc formatsf {pfx value} {
  27    foreach {min format} { 100 %.0f 10 %.1f 0 %.2f} {
  28         set fval [format $format $value]
  29         if {$fval < $min} continue
  30         return [format "$fval${pfx}" $value]
  31    }
  32 }
  33
  34 proc showintervalsecs/beat {howlong abbrev} {
  35     # We split in two to avoid overflow problems.
  36     if {$howlong < 86 } {
  37         # mB's
  38         set pfx mB
  39         return [format "%.0fmB" [expr {round($howlong * 1.157)*10} ]]
  40     } else {
  41         if {$howlong < 86400 } {
  42             # B's
  43             set pfx B
  44             set value [expr {$howlong / 86.4}]
  45         } else {
  46             # kB's
  47             set pfx kB
  48             set value [expr {$howlong / 86400.0}]
  49         }
  50     }
  51     return [formatsf $pfx $value]
  52 }
  53
  54 proc showintervalsecs/ks {howlong abbrev} {
  55     if {$howlong < 1000} {
  56         return "${howlong}s"
  57     } else {
  58         if {$howlong < 1000000} {
  59             set pfx ks
  60             set scale 1000
  61         } else {
  62             set pfx Ms
  63             set scale 1000000
  64         }
  65         set value [expr "$howlong.0 / $scale"]
  66         return [formatsf $pfx $value]
  67     }
  68 }
  69
  70 proc format_qty {qty unit abbrev} {
  71     set o $qty
  72     if {$abbrev} {
  73         append o [string range $unit 0 0]
  74     } else {
  75         append o " "
  76         append o $unit
  77         if {$qty != 1} { append o s }
  78     }
  79     return $o
  80 }
  81
  82 proc showintervalsecs/hms {qty abbrev} {
  83     set ul {second 60 minute 60 hour 24 day 7 week}
  84     set remainv 0
  85     while {[llength $ul] > 1 && $qty >= [set uv [lindex $ul 1]]} {
  86         set remainu [lindex $ul 0]
  87         set remainv [expr {$qty % $uv}]
  88         set qty [expr {($qty-$remainv)/$uv}]
  89         set ul [lreplace $ul 0 1]
  90     }
  91     set o [format_qty $qty [lindex $ul 0] $abbrev]
  92     if {$remainv} {
  93         if {!$abbrev} { append o " " }
  94         append o [format_qty $remainv $remainu $abbrev]
  95     }
  96     return $o
  97 }
  98
  99 proc showinterval {howlong} {
 100     if {$howlong <= 0} {
 101         return {just now}
 102     } else {
 103         return "[showintervalsecs $howlong 0] ago"
 104     }
 105 }
 106
 107 proc showtime {when} {
 108     return [showinterval [expr {[clock seconds] - $when}]]
 109 }
 110
 111 proc def_msgproc {name argl body} {
 112     proc msg_$name "varbase $argl" "\
 113     upvar #0 msg/\$varbase/dest d\n\
 114     upvar #0 msg/\$varbase/str s\n\
 115     upvar #0 msg/\$varbase/accum a\n\
 116 $body"
 117 }
 118
 119 def_msgproc begin {dest str} {
 120     set d $dest
 121     set s $str
 122     set a {}
 123 }
 124
 125 def_msgproc append {str} {
 126     set ns "$s$str"
 127     if {[string length $s] && [string length $ns] > 65} {
 128         msg__sendout $varbase
 129         set s " [string trimleft $str]"
 130     } else {
 131         set s $ns
 132     }
 133 }
 134
 135 def_msgproc finish {} {
 136     msg__sendout $varbase
 137     unset s
 138     unset d
 139     return $a
 140 }
 141
 142 def_msgproc _sendout {} {
 143     lappend a [string trimright $s]
 144     set s {}
 145 }
 146
 147 proc looking_whenwhere {when where} {
 148     set str [showtime [expr {$when-1}]]
 149     if {[string length $where]} { append str " on $where" }
 150     return $str
 151 }
 152
 153 proc recordlastseen_n {n how here} {
 154     global lastseen lookedfor
 155     set lastseen([irctolower $n]) [list $n [clock seconds] $how]
 156     if {!$here} return
 157     upvar #0 lookedfor([irctolower $n]) lf
 158     if {[info exists lf]} {
 159         switch -exact [llength $lf] {
 160             0 {
 161                 set ml {}
 162             }
 163             1 {
 164                 manyset [lindex $lf 0] when who where
 165                 set ml [list \
 166  "FYI, $who was looking for you [looking_whenwhere $when $where]."]
 167             }
 168             default {
 169                 msg_begin tosend $n "FYI, people have been looking for you:"
 170                 set i 0
 171                 set fin ""
 172                 foreach e $lf {
 173                     incr i
 174                     if {$i == 1} {
 175                         msg_append tosend " "
 176                     } elseif {$i == [llength $lf]} {
 177                         msg_append tosend " and "
 178                         set fin .
 179                     } else {
 180                         msg_append tosend ", "
 181                     }
 182                     manyset $e when who where
 183                     msg_append tosend \
 184                             "$who ([looking_whenwhere $when $where])$fin"
 185                 }
 186                 set ml [msg_finish tosend]
 187             }
 188         }
 189         unset lf
 190         msendprivmsg_delayed 1000 $n $ml
 191     }
 192 }
 193
 194 proc note_topic {showoff whoby topic} {
 195     set msg "FYI, $whoby has changed the topic on $showoff"
 196     if {[string length $topic] < 160} {
 197         append msg " to $topic"
 198     } else {
 199         append msg " but it is too long to reproduce here !"
 200     }
 201     set showoff [irctolower $showoff]
 202     set tell [chandb_get $showoff topictell]
 203     if {[lsearch -exact $tell *] >= 0} {
 204         set tryspies [chandb_list]
 205     } else {
 206         set tryspies $tell
 207     }
 208     foreach spy $tryspies {
 209         set see [chandb_get $spy topicsee]
 210         if {[lsearch -exact $see $showoff] >= 0 || \
 211                 ([lsearch -exact $see *] >= 0 && \
 212                 [lsearch -exact $tell $spy] >= 0)} {
 213             sendprivmsg $spy $msg
 214         }
 215     }
 216 }
 217
 218 proc recordlastseen_p {p how here} {
 219     prefix_nick
 220     recordlastseen_n $n $how $here
 221 }
 222
 223 proc chanmode_arg {} {
 224     upvar 2 args cm_args
 225     set rv [lindex $cm_args 0]
 226     set cm_args [lreplace cm_args 0 0]
 227     return $rv
 228 }
 229
 230 proc chanmode_o1 {m g p chan} {
 231     global nick chan_initialop
 232     prefix_nick
 233     set who [chanmode_arg]
 234     recordlastseen_n $n "being nice to $who" 1
 235     if {"[irctolower $who]" == "[irctolower $nick]"} {
 236         set nlower [irctolower $n]
 237         upvar #0 nick_unique($nlower) u
 238         if {[chandb_exists $chan]} {
 239             sendprivmsg $n Thanks.
 240         } elseif {![info exists u]} {
 241             sendprivmsg $n {Op me while not on the channel, why don't you ?}
 242         } else {
 243             set chan_initialop([irctolower $chan]) $u
 244             sendprivmsg $n \
 245  "Thanks. You can use `channel manager ...' to register this channel."
 246             if {![nickdb_exists $n] || ![string length [nickdb_get $n username]]} {
 247                 sendprivmsg $n \
 248  "(But to do that you must register your nick securely first.)"
 249             }
 250         }
 251     }
 252 }
 253
 254 proc chanmode_o0 {m g p chan} {
 255     global nick chandeop
 256     prefix_nick
 257     set who [chanmode_arg]
 258     recordlastseen_p $p "being mean to $who" 1
 259     if {"[irctolower $who]" == "[irctolower $nick]"} {
 260         set chandeop($chan) [list [clock seconds] $p]
 261     }
 262 }
 263
 264 proc msg_MODE {p c dest modelist args} {
 265     if {![ischan $dest]} return
 266     if {[regexp {^\-(.+)$} $modelist dummy modelist]} {
 267         set give 0
 268     } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} {
 269         set give 1
 270     } else {
 271         error "invalid modelist"
 272     }
 273     foreach m [split $modelist] {
 274         set procname chanmode_$m$give
 275         if {[catch { info body $procname }]} {
 276             recordlastseen_p $p "fiddling with $dest" 1
 277         } else {
 278             $procname $m $give  $p $dest
 279         }
 280     }
 281 }
 282
 283 proc leaving {lchan} {
 284     global nick_onchans
 285     foreach luser [array names nick_onchans] {
 286         upvar #0 nick_onchans($luser) oc
 287         set oc [grep tc {"$tc" != "$lchan"} $oc]
 288     }
 289     upvar #0 chan_nicks($lchan) nlist
 290     unset nlist
 291     upvar #0 chan_lastactivity($lchan) la
 292     catch { unset la }
 293 }
 294
 295 proc doleave {lchan} {
 296     sendout PART $lchan
 297     leaving $lchan
 298 }
 299
 300 proc dojoin {lchan} {
 301     global chan_nicks
 302     sendout JOIN $lchan
 303     set chan_nicks($lchan) {}
 304 }
 305
 306 proc check_justme {lchan} {
 307     global nick
 308     upvar #0 chan_nicks($lchan) nlist
 309     if {[llength $nlist] != 1} return
 310     if {"[lindex $nlist 0]" != "[irctolower $nick]"} return
 311     if {[chandb_exists $lchan]} {
 312         set mode [chandb_get $lchan mode]
 313         if {"$mode" != "*"} {
 314             sendout MODE $lchan $mode
 315         }
 316         set topic [chandb_get $lchan topicset]
 317         if {[string length $topic]} {
 318             sendout TOPIC $lchan $topic
 319         }
 320     } else {
 321         doleave $lchan
 322     }
 323 }
 324
 325 proc process_kickpart {chan user} {
 326     global nick
 327     check_nick $user
 328     set luser [irctolower $user]
 329     set lchan [irctolower $chan]
 330     if {![ischan $chan]} { error "not a channel" }
 331     if {"$luser" == "[irctolower $nick]"} {
 332         leaving $lchan
 333     } else {
 334         upvar #0 nick_onchans($luser) oc
 335         upvar #0 chan_nicks($lchan) nlist
 336         set oc [grep tc {"$tc" != "$lchan"} $oc]
 337         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 338         nick_case $user
 339         if {![llength $oc]} {
 340             nick_forget $luser
 341         } else {
 342             check_justme $lchan
 343         }
 344     }
 345 }
 346
 347 proc msg_TOPIC {p c dest topic} {
 348     prefix_nick
 349     if {![ischan $dest]} return
 350     recordlastseen_n $n "changing the topic on $dest" 1
 351     note_topic [irctolower $dest] $n $topic
 352 }
 353
 354 proc msg_KICK {p c chans users comment} {
 355     set chans [split $chans ,]
 356     set users [split $users ,]
 357     if {[llength $chans] > 1} {
 358         foreach chan $chans user $users { process_kickpart $chan $user }
 359     } else {
 360         foreach user $users { process_kickpart [lindex $chans 0] $user }
 361     }
 362 }
 363
 364 proc msg_KILL {p c user why} {
 365     nick_forget $user
 366 }
 367
 368 set nick_counter 0
 369 set nick_arys {onchans username unique}
 370 # nick_onchans($luser) -> [list ... $lchan ...]
 371 # nick_username($luser) -> <securely known local username>
 372 # nick_unique($luser) -> <counter>
 373 # nick_case($luser) -> $user  (valid even if no longer visible)
 374 # nick_markid($luser) -> <after id for marktime>
 375
 376 # chan_nicks($lchan) -> [list ... $luser ...]
 377 # chan_lastactivity($lchan) -> [clock seconds]
 378
 379 proc lnick_forget {luser} {
 380     global nick_arys chan_nicks
 381     lnick_marktime_cancel $luser
 382     foreach ary $nick_arys {
 383         upvar #0 nick_${ary}($luser) av
 384         catch { unset av }
 385     }
 386     foreach lch [array names chan_nicks] {
 387         upvar #0 chan_nicks($lch) nlist
 388         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 389         check_justme $lch
 390     }
 391 }
 392
 393 proc nick_forget {user} {
 394     global nick_arys chan_nicks
 395     lnick_forget [irctolower $user]
 396     nick_case $user
 397 }
 398
 399 proc nick_case {user} {
 400     global nick_case
 401     set nick_case([irctolower $user]) $user
 402 }
 403
 404 proc msg_NICK {p c newnick} {
 405     global nick_arys nick_case calling_nick
 406     prefix_nick
 407     recordlastseen_n $n "changing nicks to $newnick" 0
 408     set calling_nick $newnick
 409     recordlastseen_n $newnick "changing nicks from $n" 1
 410     set luser [irctolower $n]
 411     lnick_marktime_cancel $luser
 412     set lusernew [irctolower $newnick]
 413     foreach ary $nick_arys {
 414         upvar #0 nick_${ary}($luser) old
 415         upvar #0 nick_${ary}($lusernew) new
 416         if {[info exists new]} { error "nick collision ?! $ary $n $newnick" }
 417         if {[info exists old]} { set new $old; unset old }
 418     }
 419     upvar #0 nick_onchans($lusernew) oc
 420     foreach ch $oc {
 421         upvar #0 chan_nicks($ch) nlist
 422         set nlist [grep tn {"$tn" != "$luser"} $nlist]
 423         lappend nlist $lusernew
 424     }
 425     lnick_marktime_start $lusernew "Hi." 500
 426     nick_case $newnick
 427 }
 428
 429 proc nick_ishere {n} {
 430     global nick_counter
 431     upvar #0 nick_unique([irctolower $n]) u
 432     if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] }
 433     nick_case $n
 434 }
 435
 436 proc msg_JOIN {p c chan} {
 437     prefix_nick
 438     recordlastseen_n $n "joining $chan" 1
 439     set nl [irctolower $n]
 440     set lchan [irctolower $chan]
 441     upvar #0 nick_onchans($nl) oc
 442     upvar #0 chan_nicks($lchan) nlist
 443     if {![info exists oc]} {
 444         global marktime_join_startdelay
 445         lnick_marktime_start $nl "Welcome." $marktime_join_startdelay
 446     }
 447     lappend oc $lchan
 448     lappend nlist $nl
 449     nick_ishere $n
 450 }
 451 proc msg_PART {p c chan args} {
 452     prefix_nick
 453     set msg "leaving $chan"
 454     if {[llength $args]} {
 455         set why [lindex $args 0]
 456         if {"[irctolower $why]" != "[irctolower $n]"} { append msg " ($why)" }
 457     }
 458     recordlastseen_n $n $msg 1
 459     process_kickpart $chan $n
 460 }
 461 proc msg_QUIT {p c why} {
 462     prefix_nick
 463     recordlastseen_n $n "leaving ($why)" 0
 464     nick_forget $n
 465 }
 466
 467 proc msg_PRIVMSG {p c dest text} {
 468     global errorCode
 469
 470     prefix_nick
 471     if {[ischan $dest]} {
 472         recordlastseen_n $n "invoking me in $dest" 1
 473         set output $dest
 474     } else {
 475         recordlastseen_n $n "talking to me" 1
 476         set output $n
 477     }
 478     nick_case $n
 479
 480     execute_usercommand $p $c $n $output $dest $text
 481 }
 482
 483 proc msg_INVITE {p c n chan} {
 484     after 1000 [list dojoin [irctolower $chan]]
 485 }
 486
 487 proc grep {var predicate list} {
 488     set o {}
 489     upvar 1 $var v
 490     foreach v $list {
 491         if {[uplevel 1 [list expr $predicate]]} { lappend o $v }
 492     }
 493     return $o
 494 }
 495
 496 proc msg_353 {p c dest type chan nicklist} {
 497     global names_chans nick_onchans
 498     set lchan [irctolower $chan]
 499     upvar #0 chan_nicks($lchan) nlist
 500     lappend names_chans $lchan
 501     if {![info exists nlist]} {
 502         # We don't think we're on this channel, so ignore it !
 503         # Unfortunately, because we don't get a reply to PART,
 504         # we have to remember ourselves whether we're on a channel,
 505         # and ignore stuff if we're not, to avoid races.  Feh.
 506         return
 507     }
 508     set nlist_new {}
 509     foreach user [split $nicklist { }] {
 510         regsub {^[@+]} $user {} user
 511         if {![string length $user]} continue
 512         check_nick $user
 513         set luser [irctolower $user]
 514         upvar #0 nick_onchans($luser) oc
 515         lappend oc $lchan
 516         lappend nlist_new $luser
 517         nick_ishere $user
 518     }
 519     set nlist $nlist_new
 520 }
 521
 522 proc msg_366 {p c args} {
 523     global names_chans nick_onchans
 524     set lchan [irctolower $c]
 525     foreach luser [array names nick_onchans] {
 526         upvar #0 nick_onchans($luser) oc
 527         if {[llength names_chans] > 1} {
 528             set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc]
 529         }
 530         if {![llength $oc]} { lnick_forget $luser }
 531     }
 532     unset names_chans
 533 }
 534
 535 proc check_username {target} {
 536     if {
 537         [string length $target] > 8 ||
 538         [regexp {[^-0-9a-z]} $target] ||
 539         ![regexp {^[a-z]} $target]
 540     } { error "invalid username" }
 541 }
 542
 543 proc somedb__head {} {
 544     uplevel 1 {
 545         set idl [irctolower $id]
 546         upvar #0 ${nickchan}db($idl) ndbe
 547         binary scan $idl H* idh
 548         set idfn $fprefix$idh
 549         if {![info exists iddbe] && [file exists $idfn]} {
 550             set f [open $idfn r]
 551             try_except_finally { set newval [read $f] } {} { close $f }
 552             if {[llength $newval] % 2} { error "invalid length" }
 553             set iddbe $newval
 554         }
 555     }
 556 }
 557
 558 proc def_somedb {name arglist body} {
 559     foreach {nickchan fprefix} {nick users/n chan chans/c} {
 560         proc ${nickchan}db_$name $arglist \
 561             "set nickchan $nickchan; set fprefix $fprefix; $body"
 562     }
 563 }
 564
 565 def_somedb list {} {
 566     set list {}
 567     foreach path [glob -nocomplain -path $fprefix *] {
 568         binary scan $path "A[string length $fprefix]A*" afprefix thinghex
 569         if {"$afprefix" != "$fprefix"} { error "wrong prefix $path $afprefix" }
 570         lappend list [binary format H* $thinghex]
 571     }
 572     return $list
 573 }
 574
 575 proc def_somedb_id {name arglist body} {
 576     def_somedb $name [concat id $arglist] "somedb__head; $body"
 577 }
 578
 579 def_somedb_id exists {} {
 580     return [info exists iddbe]
 581 }
 582
 583 def_somedb_id delete {} {
 584     catch { unset iddbe }
 585     file delete $idfn
 586 }
 587
 588 set default_settings_nick {timeformat ks  marktime off}
 589 set default_settings_chan {
 590     autojoin 1
 591     mode *
 592     userinvite pub
 593     topicset {}
 594     topicsee {}
 595     topictell {}
 596 }
 597
 598 def_somedb_id set {args} {
 599     upvar #0 default_settings_$nickchan def
 600     if {![info exists iddbe]} { set iddbe $def }
 601     foreach {key value} [concat $iddbe $args] { set a($key) $value }
 602     set newval {}
 603     foreach {key value} [array get a] { lappend newval $key $value }
 604     set f [open $idfn.new w]
 605     try_except_finally {
 606         puts $f $newval
 607         close $f
 608         file rename -force $idfn.new $idfn
 609     } {
 610     } {
 611         catch { close $f }
 612     }
 613     set iddbe $newval
 614 }
 615
 616 def_somedb_id get {key} {
 617     upvar #0 default_settings_$nickchan def
 618     if {[info exists iddbe]} {
 619         set l [concat $iddbe $def]
 620     } else {
 621         set l $def
 622     }
 623     foreach {tkey value} $l {
 624         if {"$tkey" == "$key"} { return $value }
 625     }
 626     error "unset setting $key"
 627 }
 628
 629 proc opt {key} {
 630     global calling_nick
 631     if {[info exists calling_nick]} { set n $calling_nick } { set n {} }
 632     return [nickdb_get $n $key]
 633 }
 634
 635 proc check_notonchan {} {
 636     upvar 1 dest dest
 637     if {[ischan $dest]} { usererror "That command must be sent privately." }
 638 }
 639
 640 proc nick_securitycheck {strict} {
 641     upvar 1 n n
 642     if {![nickdb_exists $n]} {
 643         usererror "You are unknown to me, use `register'."
 644     }
 645     set wantu [nickdb_get $n username]
 646     if {![string length $wantu]} {
 647         if {$strict} {
 648             usererror "That feature is only available to secure users, sorry."
 649         } else {
 650             return
 651         }
 652     }
 653     set luser [irctolower $n]
 654     upvar #0 nick_username($luser) nu
 655     if {![info exists nu]} {
 656         usererror "Nick $n is secure, you must identify yourself first."
 657     }
 658     if {"$wantu" != "$nu"} {
 659         usererror "You are the wrong user -\
 660                 the nick $n belongs to $wantu, not $nu."
 661     }
 662 }
 663
 664 proc channel_ismanager {channel n} {
 665     set mgrs [chandb_get $channel managers]
 666     return [expr {[lsearch -exact [irctolower $mgrs] [irctolower $n]] >= 0}]
 667 }
 668
 669 proc channel_securitycheck {channel} {
 670     upvar n n
 671     if {![channel_ismanager $channel $n]} {
 672         usererror "You are not a manager of $channel."
 673     }
 674     nick_securitycheck 1
 675 }
 676
 677 proc def_chancmd {name body} {
 678     proc channel/$name {} \
 679             "    upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body"
 680 }
 681
 682 proc ta_listop {findnow procvalue} {
 683     # findnow and procvalue are code fragments which will be executed
 684     # in the caller's level.  findnow should set ta_listop_ev to
 685     # the current list, and procvalue should treat ta_listop_ev as
 686     # a proposed value in the list and check and possibly modify
 687     # (canonicalise?) it.  After ta_listop, ta_listop_ev will
 688     # be the new value of the list.
 689     upvar 1 ta_listop_ev exchg
 690     upvar 1 text text
 691     set opcode [ta_word]
 692     switch -exact _$opcode {
 693         _= { }
 694         _+ - _- {
 695             uplevel 1 $findnow
 696             foreach item $exchg { set array($item) 1 }
 697         }
 698         default {
 699             error "list change opcode must be one of + - ="
 700         }
 701     }
 702     foreach exchg [split $text " "] {
 703         if {![string length $exchg]} continue
 704         uplevel 1 $procvalue
 705         if {"$opcode" != "-"} {
 706             set array($exchg) 1
 707         } else {
 708             catch { unset array($exchg) }
 709         }
 710     }
 711     set exchg [lsort [array names array]]
 712 }
 713
 714 def_chancmd manager {
 715     ta_listop {
 716         if {[chandb_exists $chan]} {
 717             set ta_listop_ev [chandb_get $chan managers]
 718         } else {
 719             set ta_listop_ev [list [irctolower $n]]
 720         }
 721     } {
 722         check_nick $ta_listop_ev
 723         set ta_listop_ev [irctolower $ta_listop_ev]
 724     }
 725     if {[llength $ta_listop_ev]} {
 726         chandb_set $chan managers $ta_listop_ev
 727         ucmdr "Managers of $chan: $ta_listop_ev" {}
 728     } else {
 729         chandb_delete $chan
 730         ucmdr {} {} "forgets about managing $chan." {}
 731     }
 732 }
 733
 734 def_chancmd autojoin {
 735     set yesno [ta_word]
 736     switch -exact [string tolower $yesno] {
 737         no { set nv 0 }
 738         yes { set nv 1 }
 739         default { error "channel autojoin must be `yes' or `no' }
 740     }
 741     chandb_set $chan autojoin $nv
 742     ucmdr [expr {$nv ? "I will join $chan when I'm restarted " : \
 743             "I won't join $chan when I'm restarted "}] {}
 744 }
 745
 746 def_chancmd userinvite {
 747     set nv [string tolower [ta_word]]
 748     switch -exact $nv {
 749         pub { set txt "!invite will work for $chan, but it won't work by /msg" }
 750         here { set txt "!invite and /msg invite will work, but only for users who are already on $chan." }
 751         all { set txt "Any user will be able to invite themselves or anyone else to $chan." }
 752         none { set txt "I will not invite anyone to $chan." }
 753         default {
 754             error "channel userinvite must be `pub', `here', `all' or `none'
 755         }
 756     }
 757     chandb_set $chan userinvite $nv
 758     ucmdr $txt {}
 759 }
 760
 761 def_chancmd topic {
 762     set what [ta_word]
 763     switch -exact $what {
 764         leave {
 765             ta_nomore
 766             chandb_set $chan topicset {}
 767             ucmdr "I won't ever change the topic of $chan." {}
 768         }
 769         set {
 770             set t [string trim $text]
 771             if {![string length $t]} {
 772                 error "you must specific the topic to set"
 773             }
 774             chandb_set $chan topicset $t
 775             ucmdr "Whenever I'm alone on $chan, I'll set the topic to $t." {}
 776         }
 777         see - tell {
 778             ta_listop {
 779                 set ta_listop_ev [chandb_get $chan topic$what]
 780             } {
 781                 if {"$ta_listop_ev" != "*"} {
 782                     if {![ischan $ta_listop_ev]} {
 783                         error "bad channel \`$ta_listop_ev' in topic $what"
 784                     }
 785                     set ta_listop_ev [irctolower $ta_listop_ev]
 786                 }
 787             }
 788             chandb_set $chan topic$what $ta_listop_ev
 789             ucmdr "Topic $what list for $chan: $ta_listop_ev" {}
 790         }
 791         default {
 792             usererror "Unknown channel topic subcommand - see help channel."
 793         }
 794     }
 795 }
 796
 797 def_chancmd mode {
 798     set mode [ta_word]
 799     if {"$mode" != "*" && ![regexp {^(([-+][imnpst]+)+)$} $mode mode]} {
 800         error {channel mode must be * or match ([-+][imnpst]+)+}
 801     }
 802     chandb_set $chan mode $mode
 803     if {"$mode" == "*"} {
 804         ucmdr "I won't ever change the mode of $chan." {}
 805     } else {
 806         ucmdr "Whenever I'm alone on $chan, I'll set the mode to $mode." {}
 807     }
 808 }
 809
 810 def_chancmd show {
 811     if {[chandb_exists $chan]} {
 812         set l "Settings for $chan: autojoin "
 813         append l [lindex {no yes} [chandb_get $chan autojoin]]
 814         append l ", mode " [chandb_get $chan mode]
 815         append l ", userinvite " [chandb_get $chan userinvite] "."
 816         append l "\nManagers: "
 817         append l [join [chandb_get $chan managers] " "]
 818         foreach {ts sep} {see "\n" tell "  "} {
 819             set t [chandb_get $chan topic$ts]
 820             append l $sep
 821             if {[llength $t]} {
 822                 append l "Topic $ts list: $t."
 823             } else {
 824                 append l "Topic $ts list is empty."
 825             }
 826         }
 827         append l "\n"
 828         set t [chandb_get $chan topicset]
 829         if {[string length $t]} {
 830             append l "Topic to set: $t"
 831         } else {
 832             append l "I will not change the topic."
 833         }
 834         ucmdr {} $l
 835     } else {
 836         ucmdr {} "The channel $chan is not managed."
 837     }
 838 }
 839
 840 proc channelmgr_monoop {} {
 841     upvar 1 dest dest
 842     upvar 1 text text
 843     upvar 1 n n
 844     upvar 1 p p
 845     upvar 1 target target
 846     global chan_nicks
 847
 848     prefix_nick
 849
 850     if {[ischan $dest]} { set target $dest }
 851     if {[ta_anymore]} { set target [ta_word] }
 852     ta_nomore
 853     if {![info exists target]} {
 854         usererror "You must specify, or invoke me on, the relevant channel."
 855     }
 856     if {![info exists chan_nicks([irctolower $target])]} {
 857         usererror "I am not on $target."
 858     }
 859     if {![ischan $target]} { error "not a valid channel" }
 860
 861     if {![chandb_exists $target]} {
 862         usererror "$target is not a managed channel."
 863     }
 864     channel_securitycheck $target
 865 }
 866
 867 def_ucmd op {
 868     channelmgr_monoop
 869     sendout MODE $target +o $n
 870 }
 871
 872 def_ucmd leave {
 873     channelmgr_monoop
 874     doleave $target
 875 }
 876
 877 def_ucmd invite {
 878     global chan_nicks errorCode errorInfo
 879     prefix_nick
 880
 881     if {[ischan $dest]} {
 882         set target $dest
 883         set onchan 1
 884     } else {
 885         set target [ta_word]
 886         set onchan 0
 887     }
 888     set ltarget [irctolower $target]
 889     if {![ischan $target]} { error "$target is not a channel" }
 890     if {![info exists chan_nicks($ltarget)]} {
 891         usererror "I am not on $target."
 892     }
 893     set ui [chandb_get $ltarget userinvite]
 894     if {[catch {
 895         if {"$ui" == "pub" && !$onchan} {
 896             usererror "Invitations to $target must be made there with !invite."
 897         }
 898         if {"$ui" != "all"} {
 899             if {[lsearch -exact $chan_nicks($ltarget) [irctolower $n]] < 0} {
 900                 usererror "Invitations to $target may only be made\
 901                         by a user on the channel."
 902             }
 903         }
 904         if {"$ui" == "none"} {
 905             usererror "Sorry, I've not been authorised\
 906                     to invite people to $target."
 907         }
 908     } emsg]} {
 909         if {"$errorCode" == "BLIGHT USER" && [channel_ismanager $target $n]} {
 910             if {[catch {
 911                 nick_securitycheck 1
 912             } emsg2]} {
 913                 if {"$errorCode" == "BLIGHT USER"} {
 914                     usererror "$emsg2  Therefore you can't use your\
 915                             channel manager privilege.  $emsg"
 916                 } else {
 917                     error $error $errorInfo $errorCode
 918                 }
 919             }
 920         } else {
 921             error $emsg $errorInfo $errorCode
 922         }
 923     }
 924     if {![ta_anymore]} {
 925         usererror "You have to say who to invite."
 926     }
 927     set invitees {}
 928     while {[ta_anymore]} {
 929         set invitee [ta_word]
 930         check_nick $invitee
 931         lappend invitees $invitee
 932     }
 933     foreach invitee $invitees {
 934         sendout INVITE $invitee $ltarget
 935     }
 936     set who [lindex $invitees 0]
 937     switch -exact llength $invitees {
 938         0 { error "zero invitees" }
 939         1 { }
 940         2 { append who " and [lindex $invitees 1]" }
 941         * {
 942             set who [join [lreplace $invitees end end] ", "]
 943             append who " and [lindex $invitees [llength $invitees]]"
 944         }
 945     }
 946     ucmdr {} {} {} "invites $who to $target."
 947 }
 948
 949 def_ucmd channel {
 950     if {[ischan $dest]} { set target $dest }
 951     if {![ta_anymore]} {
 952         set subcmd show
 953     } else {
 954         set subcmd [ta_word]
 955     }
 956     if {[ischan $subcmd]} {
 957         set target $subcmd
 958         if {![ta_anymore]} {
 959             set subcmd show
 960         } else {
 961             set subcmd [ta_word]
 962         }
 963     }
 964     if {![info exists target]} { error "privately, you must specify a channel" }
 965     set procname channel/$subcmd
 966     if {"$subcmd" != "show"} {
 967         if {[catch { info body $procname }]} {
 968             usererror "unknown channel setting $subcmd."
 969         }
 970         prefix_nick
 971         if {[chandb_exists $target]} {
 972             channel_securitycheck $target
 973         } else {
 974             nick_securitycheck 1
 975             upvar #0 chan_initialop([irctolower $target]) io
 976             upvar #0 nick_unique([irctolower $n]) u
 977             if {![info exists io]} {
 978                 usererror "$target is not a managed channel."
 979             }
 980             if {"$io" != "$u"} {
 981                 usererror "You are not the interim manager of $target."
 982             }
 983             if {"$subcmd" != "manager"} {
 984                 usererror "Please use `channel manager' first."
 985             }
 986         }
 987     }
 988     channel/$subcmd
 989 }
 990
 991 def_ucmd who {
 992     if {[ta_anymore]} {
 993         set target [ta_word]; ta_nomore
 994         set myself 1
 995     } else {
 996         prefix_nick
 997         set target $n
 998         set myself [expr {"$target" != "$n"}]
 999     }
1000     set ltarget [irctolower $target]
1001     upvar #0 nick_case($ltarget) ctarget
1002     set nshow $target
1003     if {[info exists ctarget]} {
1004         upvar #0 nick_onchans($ltarget) oc
1005         upvar #0 nick_username($ltarget) nu
1006         if {[info exists oc]} { set nshow $ctarget }
1007     }
1008     if {![nickdb_exists $ltarget]} {
1009         set ol "$nshow is not a registered nick."
1010     } elseif {[string length [set username [nickdb_get $target username]]]} {
1011         set ol "The nick $nshow belongs to the user $username."
1012     } else {
1013         set ol "The nick $nshow is registered (but not to a username)."
1014     }
1015     if {![info exists ctarget] || ![info exists oc]} {
1016         if {$myself} {
1017             append ol "\nI can't see $nshow on anywhere."
1018         } else {
1019             append ol "\nYou aren't on any channels with me."
1020         }
1021     } elseif {![info exists nu]} {
1022         append ol "\n$nshow has not identified themselves."
1023     } elseif {![info exists username]} {
1024         append ol "\n$nshow has identified themselves as the user $nu."
1025     } elseif {"$nu" != "$username"} {
1026         append ol "\nHowever, $nshow is being used by the user $nu."
1027     } else {
1028         append ol "\n$nshow has identified themselves to me."
1029     }
1030     ucmdr {} $ol
1031 }
1032
1033 def_ucmd register {
1034     prefix_nick
1035     check_notonchan
1036     set old [nickdb_exists $n]
1037     if {$old} { nick_securitycheck 0 }
1038     set luser [irctolower $n]
1039     switch -exact [string tolower [string trim $text]] {
1040         {} {
1041             upvar #0 nick_username($luser) nu
1042             if {![info exists nu]} {
1043                 ucmdr {} \
1044  "You must identify yourself before using `register'.  See `help identify', or use `register insecure'."
1045             }
1046             nickdb_set $n username $nu
1047             ucmdr {} {} "makes a note of your username." {}
1048         }
1049         delete {
1050             nickdb_delete $n
1051             ucmdr {} {} "forgets your nickname." {}
1052         }
1053         insecure {
1054             nickdb_set $n username {}
1055             if {$old} {
1056                 ucmdr {} "Security is now disabled for your nickname !"
1057             } else {
1058                 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."
1059             }
1060         }
1061         default {
1062             error "you mean register / register delete / register insecure"
1063         }
1064     }
1065 }
1066
1067 proc timeformat_desc {tf} {
1068     switch -exact $tf {
1069         ks { return "Times will be displayed in seconds or kiloseconds." }
1070         hms { return "Times will be displayed in hours, minutes, etc." }
1071         beat { return "Times will be displayed in beats (1000B = 1d)." }
1072         default { error "invalid timeformat: $v" }
1073     }
1074 }
1075
1076 proc def_setting {opt show_body set_body} {
1077     proc set_show/$opt {} "
1078         upvar 1 n n
1079         set opt $opt
1080         $show_body"
1081     if {![string length $set_body]} return
1082     proc set_set/$opt {} "
1083         upvar 1 n n
1084         upvar 1 text text
1085         set opt $opt
1086         $set_body"
1087 }
1088
1089 def_setting timeformat {
1090     set tf [nickdb_get $n timeformat]
1091     return "$tf: [timeformat_desc $tf]"
1092 } {
1093     set tf [string tolower [ta_word]]
1094     ta_nomore
1095     set desc [timeformat_desc $tf]
1096     nickdb_set $n timeformat $tf
1097     ucmdr {} $desc
1098 }
1099
1100 proc marktime_desc {mt} {
1101     if {"$mt" == "off"} {
1102         return "I will not send you periodic messages."
1103     } elseif {"$mt" == "once"} {
1104         return "I will send you one informational message when I see you."
1105     } else {
1106         return "I'll send you a message every [showintervalsecs $mt 0]."
1107     }
1108 }
1109
1110 def_setting marktime {
1111     set mt [nickdb_get $n marktime]
1112     set p $mt
1113     if {[string match {[0-9]*} $mt]} { append p s }
1114     append p ": "
1115     append p [marktime_desc $mt]
1116     return $p
1117 } {
1118     global marktime_min
1119     set mt [string tolower [ta_word]]
1120     ta_nomore
1121
1122     if {"$mt" == "off" || "$mt" == "once"} {
1123     } elseif {[regexp {^([0-9]+)([a-z]+)$} $mt dummy value unit]} {
1124         switch -exact $unit {
1125             s { set u 1 }
1126             ks { set u 1000 }
1127             m { set u 60 }
1128             mb { set u 0.0864 }
1129             b { set u 86.4 }
1130             kb { set u 86400 }
1131             default { error "unknown unit of time $unit" }
1132         }
1133         if {$value > 86400*21/$u} { error "marktime interval too large" }
1134         set mt [expr {round($value*$u)}]
1135         if {$mt < $marktime_min} { error "marktime interval too small" }
1136     } else {
1137         error "invalid syntax for marktime"
1138     }
1139     nickdb_set $n marktime $mt
1140     lnick_marktime_start [irctolower $n] "So:" 500
1141     ucmdr {} [marktime_desc $mt]
1142 }
1143
1144 def_setting security {
1145     set s [nickdb_get $n username]
1146     if {[string length $s]} {
1147         return "Your nick, $n, is controlled by the user $s."
1148     } else {
1149         return "Your nick, $n, is not secure."
1150     }
1151 } {}
1152
1153 def_ucmd set {
1154     prefix_nick
1155     check_notonchan
1156     if {![nickdb_exists $n]} {
1157         ucmdr {} "You are unknown to me and so have no settings.  (Use `register'.)"
1158     }
1159     if {![ta_anymore]} {
1160         set ol {}
1161         foreach proc [lsort [info procs]] {
1162             if {![regexp {^set_show/(.*)$} $proc dummy opt]} continue
1163             lappend ol [format "%-10s %s" $opt [set_show/$opt]]
1164         }
1165         ucmdr {} [join $ol "\n"]
1166     } else {
1167         set opt [ta_word]
1168         if {[catch { info body set_show/$opt }]} {
1169             error "no setting $opt"
1170         }
1171         if {![ta_anymore]} {
1172             ucmdr {} "$opt [set_show/$opt]"
1173         } else {
1174             nick_securitycheck 0
1175             if {[catch { info body set_set/$opt }]} {
1176                 error "setting $opt cannot be set with `set'"
1177             }
1178             set_set/$opt
1179         }
1180     }
1181 }
1182
1183 def_ucmd identpass {
1184     set username [ta_word]
1185     set passmd5 [md5sum "[ta_word]\n"]
1186     ta_nomore
1187     prefix_nick
1188     check_notonchan
1189     set luser [irctolower $n]
1190     upvar #0 nick_onchans($luser) onchans
1191     if {![info exists onchans] || ![llength $onchans]} {
1192         ucmdr "You must be on a channel with me to identify yourself." {}
1193     }
1194     check_username $username
1195     exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \
1196             irc-identpass $n
1197     upvar #0 nick_username($luser) rec_username
1198     set rec_username $username
1199     ucmdr "Pleased to see you, $username." {}
1200 }
1201
1202 def_ucmd kill {
1203     global nick
1204     prefix_nick
1205     set target [ta_nick]
1206     if {![nickdb_exists $target]} { error "$target is not a registered nick." }
1207     set wantu [nickdb_get $target username]
1208     if {![string length $wantu]} { error "$target is insecurely registred." }
1209     upvar #0 nick_username([irctolower $n]) nu
1210     if {![info exists nu]} { error "You must identify yourself first." }
1211     if {"$wantu" != "$nu"} {
1212         error "You are the wrong user, $nu - $target belongs to $wantu."
1213     }
1214     set reason "at request of user $nu"
1215     if {[ta_anymore]} { append reason "; $text" }
1216     sendout KILL $target $reason
1217 }
1218
1219 def_ucmd summon {
1220     set target [ta_word]
1221     ta_nomore
1222     # fixme would be nice if the rest of the text was passed on instead
1223     check_username $target
1224     prefix_nick
1225
1226     upvar #0 lastsummon($target) ls
1227     set now [clock seconds]
1228     if {[info exists ls]} {
1229         set interval [expr {$now - $ls}]
1230         if {$interval < 30} {
1231             ucmdr {} \
1232  "Please be patient; $target was summoned only [showinterval $interval]."
1233         }
1234     }
1235     regsub {^[^!]*!} $p {} path
1236     if {[catch {
1237         exec userv --timeout 3 $target irc-summon $n $path \
1238                 [expr {[ischan $dest] ? "$dest" : ""}] \
1239                 < /dev/null
1240     } rv]} {
1241         regsub -all "\n" $rv { / } rv
1242         error $rv
1243     }
1244     if {[regexp {^problem (.*)} $rv dummy problem]} {
1245         ucmdr {} "The user `$target' $problem."
1246     } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} {
1247         set idletime [expr {$now - $idlesince}]
1248         set ls $now
1249         ucmdr {} {} {} "invites $target ($tty[expr {
1250             $idletime > 10 ? ", idle for [showintervalsecs $idletime 0]" : ""
1251         }]) to [expr {
1252             [ischan $dest] ? "join us here" : "talk to you"
1253         }]."
1254     } else {
1255         error "unexpected response from userv service: $rv"
1256     }
1257 }
1258
1259 proc md5sum {value} { exec md5sum << $value }
1260
1261 def_ucmd seen {
1262     global lastseen nick
1263     prefix_nick
1264     set ncase [ta_nick]
1265     set nlower [irctolower $ncase]
1266     ta_nomore
1267     set now [clock seconds]
1268     if {"$nlower" == "[irctolower $nick]"} {
1269         usererror "I am not self-aware."
1270     } elseif {![info exists lastseen($nlower)]} {
1271         set rstr "I've never seen $ncase."
1272     } else {
1273         manyset $lastseen($nlower) realnick time what
1274         set howlong [expr {$now - $time}]
1275         set string [showinterval $howlong]
1276         set rstr "I last saw $realnick $string, $what."
1277     }
1278     if {[ischan $dest]} {
1279         set where $dest
1280     } else {
1281         set where {}
1282     }
1283     upvar #0 lookedfor($nlower) lf
1284     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
1285     set lf [list [list $now $n $where]]
1286     foreach v $oldvalue {
1287         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
1288         lappend lf $v
1289     }
1290     ucmdr {} $rstr
1291 }
1292
1293 proc lnick_marktime_cancel {luser} {
1294     upvar #0 nick_markid($luser) mi
1295     if {![info exists mi]} return
1296     catch { after cancel $mi }
1297     catch { unset mi }
1298 }
1299
1300 proc lnick_marktime_doafter {luser why ms} {
1301     lnick_marktime_cancel $luser
1302     upvar #0 nick_markid($luser) mi
1303     set mi [after $ms [list lnick_marktime_now $luser $why]]
1304 }
1305
1306 proc lnick_marktime_reset {luser} {
1307     set mt [nickdb_get $luser marktime]
1308     if {"$mt" == "off" || "$mt" == "once"} return
1309     lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}]
1310 }
1311
1312 proc lnick_marktime_start {luser why ms} {
1313     set mt [nickdb_get $luser marktime]
1314     if {"$mt" == "off"} {
1315         lnick_marktime_cancel $luser
1316     } else {
1317         lnick_marktime_doafter $luser $why $ms
1318     }
1319 }
1320
1321 proc lnick_marktime_now {luser why} {
1322     upvar #0 nick_onchans($luser) oc
1323     global calling_nick
1324     set calling_nick $luser
1325     sendprivmsg $luser [lnick_pingstring $why $oc ""]
1326     lnick_marktime_reset $luser
1327 }
1328
1329 proc lnick_pingstring {why oc apstring} {
1330     global nick_onchans
1331     catch { exec uptime } uptime
1332     set nnicks [llength [array names nick_onchans]]
1333     if {[regexp \
1334  {^ *([0-9:apm]+) +up.*, +(\d+) users?, +load average: +([0-9., ]+) *$} \
1335             $uptime dummy time users load]} {
1336         regsub -all , $load {} load
1337         set uptime "$time  $nnicks/$users  $load"
1338     } else {
1339         append uptime ", $nnicks nicks"
1340     }
1341     if {[llength $oc]} {
1342         set best_la 0
1343         set activity quiet
1344         foreach ch $oc {
1345             upvar #0 chan_lastactivity($ch) la
1346             if {![info exists la]} continue
1347             if {$la <= $best_la} continue
1348             set since [showintervalsecs [expr {[clock seconds]-$la}] 1]
1349             set activity "$ch $since"
1350             set best_la $la
1351         }
1352     } else {
1353         set activity unseen
1354     }
1355     set str $why
1356     append str "  " $uptime "  " $activity
1357     if {[string length $apstring]} { append str "  " $apstring }
1358     return $str
1359 }
1360
1361 def_ucmd ping {
1362     if {[ischan $dest]} {
1363         set oc [irctolower $dest]
1364     } else {
1365         global nick_onchans
1366         prefix_nick
1367         set ln [irctolower $n]
1368         if {[info exists nick_onchans($ln)]} {
1369             set oc $nick_onchans($ln)
1370         } else {
1371             set oc {}
1372         }
1373         if {[llength $oc]} { lnick_marktime_reset $ln }
1374     }
1375     ucmdr {} [lnick_pingstring "Pong!" $oc $text]
1376 }
1377
1378 proc ensure_globalsecret {} {
1379     global globalsecret
1380
1381     if {[info exists globalsecret]} return
1382     set gsfile [open /dev/urandom r]
1383     fconfigure $gsfile -translation binary
1384     set globalsecret [read $gsfile 32]
1385     binary scan $globalsecret H* globalsecret
1386     close $gsfile
1387     unset gsfile
1388 }
1389
1390 proc connected {} {
1391     global operuserpass
1392     if {[info exists operuserpass]} {
1393         eval sendout OPER $operuserpass
1394     }
1395     foreach chan [chandb_list] {
1396         if {[chandb_get $chan autojoin]} { dojoin $chan }
1397     }
1398 }
1399
1400 ensure_globalsecret
1401 loadhelp
1402 ensure_connecting