| 1 | proc defset {varname val} { |
| 2 | upvar 1 $varname var |
| 3 | if {![info exists var]} { set var $val } |
| 4 | } |
| 5 | |
| 6 | # must set host |
| 7 | defset port 6667 |
| 8 | defset socketargs {} |
| 9 | |
| 10 | defset nick testbot |
| 11 | defset ident blight |
| 12 | defset ownfullname "testing bot" |
| 13 | defset ownmailaddr test-irc-bot@example.com |
| 14 | |
| 15 | defset muststartby_ms 10000 |
| 16 | defset out_maxburst 6 |
| 17 | defset out_interval 2100 |
| 18 | defset out_lag_lag 5000 |
| 19 | defset out_lag_very 25000 |
| 20 | defset ownping_every 300000 |
| 21 | |
| 22 | proc manyset {list args} { |
| 23 | foreach val $list var $args { |
| 24 | upvar 1 $var my |
| 25 | set my $val |
| 26 | } |
| 27 | } |
| 28 | |
| 29 | proc try_except_finally {try except finally} { |
| 30 | global errorInfo errorCode |
| 31 | set er [catch { uplevel 1 $try } emsg] |
| 32 | if {$er} { |
| 33 | set ei $errorInfo |
| 34 | set ec $errorCode |
| 35 | if {[catch { uplevel 1 $except } emsg3]} { |
| 36 | append ei "\nALSO ERROR HANDLING ERROR:\n$emsg3" |
| 37 | } |
| 38 | } |
| 39 | set er2 [catch { uplevel 1 $finally } emsg2] |
| 40 | if {$er} { |
| 41 | if {$er2} { |
| 42 | append ei "\nALSO ERROR CLEANING UP:\n$emsg2" |
| 43 | } |
| 44 | return -code $er -errorinfo $ei -errorcode $ec $emsg |
| 45 | } elseif {$er2} { |
| 46 | return -code $er2 -errorinfo $errorInfo -errorcode $errorCode $emsg2 |
| 47 | } else { |
| 48 | return $emsg |
| 49 | } |
| 50 | } |
| 51 | |
| 52 | proc out__vars {} { |
| 53 | uplevel 1 { |
| 54 | global out_queue out_creditms out_creditat out_interval out_maxburst |
| 55 | global out_lag_lag out_lag_very |
| 56 | #set pr [lindex [info level 0] 0] |
| 57 | #puts $pr>[clock seconds]|$out_creditat|$out_creditms|[llength $out_queue]< |
| 58 | } |
| 59 | } |
| 60 | |
| 61 | proc out_lagged {} { |
| 62 | out__vars |
| 63 | if {[llength $out_queue]*$out_interval > $out_lag_very} { |
| 64 | return 2 |
| 65 | } elseif {[llength $out_queue]*$out_interval > $out_lag_lag} { |
| 66 | return 1 |
| 67 | } else { |
| 68 | return 0 |
| 69 | } |
| 70 | } |
| 71 | |
| 72 | proc out_restart {} { |
| 73 | out__vars |
| 74 | |
| 75 | set now [clock seconds] |
| 76 | incr out_creditms [expr {($now - $out_creditat) * 1000}] |
| 77 | set out_creditat $now |
| 78 | if {$out_creditms > $out_maxburst*$out_interval} { |
| 79 | set out_creditms [expr {$out_maxburst*$out_interval}] |
| 80 | } |
| 81 | out_runqueue $now |
| 82 | } |
| 83 | |
| 84 | proc out_runqueue {now} { |
| 85 | global sock |
| 86 | out__vars |
| 87 | |
| 88 | while {[llength $out_queue] && $out_creditms >= $out_interval} { |
| 89 | #puts rq>$now|$out_creditat|$out_creditms|[llength $out_queue]< |
| 90 | manyset [lindex $out_queue 0] orgwhen msg |
| 91 | set out_queue [lrange $out_queue 1 end] |
| 92 | if {[llength $out_queue]} { |
| 93 | append orgwhen "+[expr {$now - $orgwhen}]" |
| 94 | append orgwhen "([llength $out_queue])" |
| 95 | } |
| 96 | puts "$orgwhen -> $msg" |
| 97 | puts $sock $msg |
| 98 | incr out_creditms -$out_interval |
| 99 | } |
| 100 | if {[llength $out_queue]} { |
| 101 | after $out_interval out_nextmessage |
| 102 | } |
| 103 | } |
| 104 | |
| 105 | proc out_nextmessage {} { |
| 106 | out__vars |
| 107 | set now [clock seconds] |
| 108 | incr out_creditms $out_interval |
| 109 | set out_creditat $now |
| 110 | out_runqueue $now |
| 111 | } |
| 112 | |
| 113 | proc sendout_priority {priority command args} { |
| 114 | global sock out_queue |
| 115 | if {[llength $args]} { |
| 116 | set la [lindex $args end] |
| 117 | set args [lreplace $args end end] |
| 118 | foreach i $args { |
| 119 | if {[regexp {[: ]} $i]} { |
| 120 | error "bad argument in output $i ($command $args)" |
| 121 | } |
| 122 | } |
| 123 | lappend args :$la |
| 124 | } |
| 125 | set args [lreplace $args 0 -1 $command] |
| 126 | set string [join $args { }] |
| 127 | set now [clock seconds] |
| 128 | set newe [list $now $string] |
| 129 | if {$priority} { |
| 130 | set out_queue [concat [list $newe] $out_queue] |
| 131 | } else { |
| 132 | lappend out_queue $newe |
| 133 | } |
| 134 | if {[llength $out_queue] == 1} { |
| 135 | out_restart |
| 136 | } |
| 137 | } |
| 138 | |
| 139 | proc sendout {command args} { eval sendout_priority [list 0 $command] $args } |
| 140 | |
| 141 | proc log {data} { |
| 142 | puts $data |
| 143 | } |
| 144 | |
| 145 | proc log_intern {what data} { |
| 146 | puts "[clock seconds] ++ $what $data" |
| 147 | } |
| 148 | |
| 149 | proc logerror {data} { |
| 150 | log $data |
| 151 | } |
| 152 | |
| 153 | proc saveeic {} { |
| 154 | global saveei saveec errorInfo errorCode |
| 155 | |
| 156 | set saveei $errorInfo |
| 157 | set saveec $errorCode |
| 158 | |
| 159 | puts ">$saveec|$saveei<" |
| 160 | } |
| 161 | |
| 162 | proc bgerror {msg} { |
| 163 | global save |
| 164 | logerror $msg |
| 165 | saveeic |
| 166 | } |
| 167 | |
| 168 | proc onread {args} { |
| 169 | global sock nick calling_nick errorInfo errorCode line_org_endchar |
| 170 | |
| 171 | if {[catch { gets $sock line } rv]} { fail "error on input: $rv" } |
| 172 | if {$rv == -1} { fail "EOF on input" } |
| 173 | |
| 174 | set line_org_endchar [string range $line end end] |
| 175 | regsub -all "\[^ -\176\240-\376\]" $line ? line |
| 176 | set org $line |
| 177 | |
| 178 | new_event |
| 179 | |
| 180 | if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} { |
| 181 | set line $remain |
| 182 | if {[regexp {^([^!]+)!} $prefix dummy maybenick]} { |
| 183 | set calling_nick $maybenick |
| 184 | if {![ircnick_compare $maybenick $nick]} return |
| 185 | } |
| 186 | } else { |
| 187 | set prefix {} |
| 188 | } |
| 189 | if {![string length $line]} { return } |
| 190 | if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} { |
| 191 | log "bad command: $org" |
| 192 | return |
| 193 | } |
| 194 | set command [string toupper $command] |
| 195 | set params {} |
| 196 | while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} { |
| 197 | lappend params $thisword |
| 198 | } |
| 199 | if {[regexp {^:(.*)} $line dummy thisword]} { |
| 200 | lappend params $thisword |
| 201 | } elseif {[string length $line]} { |
| 202 | log "junk at end: $org" |
| 203 | return |
| 204 | } |
| 205 | if {![string compare $command "PRIVMSG"] && \ |
| 206 | [privmsg_unlogged $prefix [ischan [lindex $params 0]] $params]} { |
| 207 | return |
| 208 | } |
| 209 | log "[clock seconds] <- $org" |
| 210 | set procname msg_$command |
| 211 | if {[catch { info body $procname }]} { return } |
| 212 | if {[catch { |
| 213 | eval [list $procname $prefix $command] $params |
| 214 | } emsg]} { |
| 215 | logerror "error: $emsg ($prefix $command $params)" |
| 216 | saveeic |
| 217 | } |
| 218 | } |
| 219 | |
| 220 | proc catch_restoreei {body} { |
| 221 | global errorInfo errorCode |
| 222 | set l [list $errorInfo $errorCode] |
| 223 | catch { uplevel 1 $body } |
| 224 | manyset $l errorInfo errorCode |
| 225 | } |
| 226 | |
| 227 | proc catch_logged {body} { |
| 228 | global errorInfo |
| 229 | if {[catch { uplevel 1 $body } emsg]} { |
| 230 | logerror "error (catch_logged): $emsg\n $errorInfo" |
| 231 | } |
| 232 | } |
| 233 | |
| 234 | proc sendprivmsg {dest l} { |
| 235 | foreach v [split $l "\n"] { |
| 236 | sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $v |
| 237 | } |
| 238 | } |
| 239 | proc sendaction_priority {priority dest what} { |
| 240 | sendout_priority $priority PRIVMSG $dest "\001ACTION $what\001" |
| 241 | } |
| 242 | proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } } |
| 243 | proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] } |
| 244 | |
| 245 | proc check_nick {n} { |
| 246 | if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" } |
| 247 | if {[regexp {^[-0-9]} $n]} { error "bad nick start" } |
| 248 | if {[string length $n] > 18} { error "nick too long" } |
| 249 | } |
| 250 | |
| 251 | proc check_chan {n} { |
| 252 | if {![regsub {^\#} $n {} n]} { error "bad chan start" } |
| 253 | if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in chan" } |
| 254 | if {[regexp {^[-0-9]} $n]} { error "bad chan name start" } |
| 255 | if {[string length $n] > 18} { error "chan name too long" } |
| 256 | } |
| 257 | |
| 258 | proc ischan {dest} { |
| 259 | return [regexp {^[&#+!]} $dest] |
| 260 | } |
| 261 | |
| 262 | proc irctolower {v} { |
| 263 | foreach {from to} [list "\\\[" "{" \ |
| 264 | "\\\]" "}" \ |
| 265 | "\\\\" "|" \ |
| 266 | "~" "^"] { |
| 267 | regsub -all $from $v $to v |
| 268 | } |
| 269 | return [string tolower $v] |
| 270 | } |
| 271 | |
| 272 | proc ircnick_compare {a b} { |
| 273 | return [string compare [irctolower $a] [irctolower $b]] |
| 274 | } |
| 275 | |
| 276 | proc prefix_none {} { |
| 277 | upvar 1 p p |
| 278 | if {[string length $p]} { error "prefix specified" } |
| 279 | } |
| 280 | |
| 281 | proc prefix_nick {} { |
| 282 | global nick |
| 283 | upvar 1 p p |
| 284 | upvar 1 n n |
| 285 | if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" } |
| 286 | check_nick $n |
| 287 | if {![ircnick_compare $n $nick]} { |
| 288 | error "from myself" {} {} |
| 289 | } |
| 290 | } |
| 291 | |
| 292 | proc msg_PING {p c s1} { |
| 293 | prefix_none |
| 294 | sendout PONG $s1 |
| 295 | } |
| 296 | |
| 297 | proc sendownping {} { |
| 298 | global ownping_every nick |
| 299 | sendout ping $nick |
| 300 | after $ownping_every sendownping |
| 301 | } |
| 302 | |
| 303 | proc msg_001 {args} { |
| 304 | global muststartby_after |
| 305 | if {[info exists muststartby_after]} { |
| 306 | after cancel $muststartby_after |
| 307 | unset muststartby_after |
| 308 | sendownping |
| 309 | connected |
| 310 | } |
| 311 | } |
| 312 | |
| 313 | proc ensure_outqueue {} { |
| 314 | out__vars |
| 315 | if {[info exists out_queue]} return |
| 316 | set out_creditms 0 |
| 317 | set out_creditat [clock seconds] |
| 318 | set out_queue {} |
| 319 | set out_lag_reported 0 |
| 320 | set out_lag_reportwhen $out_creditat |
| 321 | } |
| 322 | |
| 323 | proc fail {msg} { |
| 324 | logerror "failing: $msg" |
| 325 | exit 1 |
| 326 | } |
| 327 | |
| 328 | proc ensure_connecting {} { |
| 329 | global sock ownfullname host port nick ident socketargs |
| 330 | global muststartby_ms muststartby_after |
| 331 | |
| 332 | ensure_outqueue |
| 333 | |
| 334 | if {[info exists sock]} return |
| 335 | set sock [eval socket $socketargs [list $host $port]] |
| 336 | fconfigure $sock -buffering line |
| 337 | fconfigure $sock -translation crlf |
| 338 | |
| 339 | sendout USER $ident 0 * $ownfullname |
| 340 | sendout NICK $nick |
| 341 | fileevent $sock readable onread |
| 342 | |
| 343 | set muststartby_after [after $muststartby_ms \ |
| 344 | {fail "no successfuly connect within timeout"}] |
| 345 | } |