Author | Post |
Topic: [EGG] Debugger Forum: #tcl › code snippets Goto post |
thommey  | 09-04-2014, 03:55 | [EGG] Debugger | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Here's a utility script that lets you see debugging information about your script on loglevel 6 (.console +6). To use, use .tcl traceonce/traceon/traceoff <procname>.
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
proc traceonce {proc {level -1}} {
trace add execution $proc {enter leave enterstep leavestep} [list debugger $proc 1 $level]
}
proc traceon {proc {level -1}} {
trace add execution $proc {enter leave enterstep leavestep} [list debugger $proc 0 $level]
}
proc traceoff {proc {level -1}} {
trace remove execution $proc {enter leave enterstep leavestep} [list debugger $proc 0 $level]
}
proc indent {cmd dir} {
if {![info exists ::indent($cmd)]} {
set ::indent($cmd) 0
}
set old $::indent($cmd)
set new [incr ::indent($cmd) $dir]
set i [expr {$dir == 1 ? 2*$new : 2*$old}]
string repeat " " $i
}
proc res2str {res} {
switch -exact -- $res {
0 { return "ok" }
1 { return "error" }
2 { return "return" }
3 { return "break" }
4 { return "continue" }
default { return "errcode $res" }
}
}
proc debugger {proc once maxlevel cmd args} {
set op [lindex $args end]
foreach word $cmd {
if {[string length $word] > 50} {
lappend words "[string range $word 0 49]<...>"
} else {
lappend words $word
}
}
set cmd $words
if {[string length $cmd] > 250} {
set cmd [string range $cmd 0 249]<...>
}
switch -exact -- $op {
enter -
enterstep {
set indent [indent $proc +1]
if {$maxlevel == -1 || [string length $indent]/2 <= $maxlevel} {
putloglev 6 * "DEBUG ($proc): $indent ${op} \[$cmd\]"
}
}
leave -
leavestep {
set indent [indent $proc -1]
lassign $args res resstr
if {$maxlevel == -1 || [string length $indent]/2 <= $maxlevel} {
putloglev 6 * "DEBUG ($proc): $indent ${op} \[$cmd\] = ([res2str $res]) {$resstr}"
}
}
}
if {$op eq "leave" && $once} {
trace remove execution [lindex $cmd 0] {enter leave enterstep leavestep} [list debugger $proc $once $maxlevel]
}
}
|
 |
 |
Topic: 2 minute timer (timer help) Forum: eggdrop › help Goto post |
thommey  | 02-08-2014, 08:20 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| either:
bind time - "?0 * * * *" procname
bind time - "?2 * * * *" procname
bind time - "?4 * * * *" procname
bind time - "?6 * * * *" procname
bind time - "?8 * * * *" procname
or as of eggdrop1.6.20:
bind cron - "*/2 * * * *" procname  |
 |
Topic: Expect logging issue (Logs dont contain the data sent toward them.) Forum: eggdrop › help Goto post |
thommey  | 05-15-2013, 20:01 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| try moving both your [open .. w] statements to before the while loop, you should only be opening and closing these files once - not in a loop.  |
 |
Topic: [Site] Paste site Forum: work › script announcements Goto post |
thommey  | 05-19-2012, 01:24 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Just a quick FYI:
I attempted to fix the line numbers not aligning properly with the code, depending on operating system + browser combination. While doing that, I also wanted to try out a new font for the code (which should work in all modern browsers, the 0 has a little dot in the middle to distinguish it from the O). Feedback is welcome!  |
 |
Topic: errorInfo tracen, aber nur für ungecatchte Fehler Forum: work › imminent problem solving Goto post |
thommey  | 11-03-2011, 18:26 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Die bgerror Variable wird, im Fehlerfall, von unten nach oben ergänzt, also jedes Stacklevel fügt "invoked by ..." hinzu, deswegen siehst du viele Schreibzugriffe. Die bgerror Variable zu tracen ist, wegen der später abgefangenen Fehler mit [catch], auch nicht die Methode der Wahl um das Problem des fehlenden genauen Errorreportings zu lösen.
Die Lösung des Problems liegt ausschließlich im patchen von Eggdrop mit so etwas wie...:
http://thommey.tclhelp.net/bgerror.patch.txt
was dann dafür sorgt, dass [interp bgerror] bzw. [bgerror] aufgerufen wird (siehe http://tclhelp.net/tcl/bgerror und http://tclhelp.net/tcl/interp#M10), in denen du dann einfach $::errorInfo vollständig auf die partyline ausgeben kannst (oder sonstwas mit dem Fehler machen).  |
 |
Topic: [TCL] Human readable file sizes Forum: #tcl › code snippets Goto post |
thommey  | 10-30-2011, 00:35 | [TCL] Human readable file sizes | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
|
# Returns a human readable representation of the "size" argument, which is in bytes
# the second argument specifies the number of digits after the . you want to have
proc humanify {size {digits 2}} {
foreach prefix {B kiB MiB GiB TiB PiB} {
set new [expr {$size/1024.0}]
if {$new < 1} { break }
set size $new
}
return "[format %.*f $digits $size] $prefix"
}
|
 |
 |
Topic: [TCL] Ridiculously complicated regular expressions Forum: #tcl › code snippets Goto post |
thommey  | 01-21-2011, 23:10 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Created by Pixelz
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
# Checks to see if the supplied cron is valid:
proc ::cron::valid {cron} {
# This RE consists of 5 instances of the same basic RE. Each instance has
# "\d+" substituted for a RE that validates the number sequence associated
# with that instance.
#
# Base Regex, explained:
# Match any number of comma separated items if there are any:
# (0*\d+|\*)(-0*\d+)?(/\d+)?,)*
# Match the last item in this instance:
# (0*\d+|\*)(-0*\d+)?(/\d+)?\s
regexp -expanded -- {
# minute (0-59) - ([0-9]|[1-5][0-9])
^((0*([0-9]|[1-5][0-9])|\*)(-0*([0-9]|[1-5][0-9]))?(/\d+)?,)*
(0*([0-9]|[1-5][0-9])|\*)(-0*([0-9]|[1-5][0-9]))?(/\d+)?\s
# hour (0-23) - ([0-9]|1[0-9]|2[0-3])
((0*([0-9]|1[0-9]|2[0-3])|\*)(-0*([0-9]|1[0-9]|2[0-3]))?(/\d+)?,)*
(0*([0-9]|1[0-9]|2[0-3])|\*)(-0*([0-9]|1[0-9]|2[0-3]))?(/\d+)?\s
# day of month (1-31) - ([1-9]|[12][0-9]3[01])
((0*([1-9]|[12][0-9]3[01])|\*)(-0*([1-9]|[12][0-9]3[01]))?(/\d+)?,)*
(0*([1-9]|[12][0-9]3[01])|\*)(-0*([1-9]|[12][0-9]3[01]))?(/\d+)?\s
# month (1-12) - ([1-9]|1[0-2])
((0*([1-9]|1[0-2])|\*)(-0*([1-9]|1[0-2]))?(/\d+)?,)*
(0*([1-9]|1[0-2])|\*)(-0*([1-9]|1[0-2]))?(/\d+)?\s
# day of week (0-7) - [0-7]
((0*[0-7]|\*)(-0*[0-7])?(/\d+)?,)*
(0*[0-7]|\*)(-0*[0-7])?(/\d+)?$
} $cron
}
|
 |
 |
Topic: [EGG/TCL] tail -f in the background Forum: #tcl › code snippets Goto post |
thommey  | 09-07-2010, 02:53 | [EGG/TCL] tail -f in the background | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
1
2
3
4
|
set f [open "|tail -f /var/log/messages"]
fconfigure $f -blocking 0 -buffering line
fileevent $f readable [list foo $f]
proc foo {f} {puthelp "privmsg #chan :[gets $f]"}
|
(probably from demond on the egghelp.org forum)  |
 |
Topic: [TCL] Coroutine enabled portscanner Forum: #tcl › code snippets Goto post |
thommey  | 09-01-2010, 16:18 | [TCL] Coroutine enabled portscanner | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Self-documenting
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
#!/usr/bin/env tclsh8.6
# portscan.tcl
package require Tcl 8.6
# Helper function 1 (uplevel executes in callers stack - just code grouping)
proc portscan_getfeedback {} {
uplevel 1 {
lassign [yield] s port state
incr myconns -1
while {$state eq "timeout" && $port in $notimeoutports} {
lassign [yield] s port state
}
}
}
# Helper function 2 (uplevel executes in callers stack - just code grouping)
proc portscan_assignstate {} {
uplevel 1 {
if {$state eq "open"} {
lappend notimeoutports $port
if {[fconfigure $s -error] eq ""} {
lappend openports $port
}
}
catch {close $s}
}
}
# Here's the real thing.
# Syntax: portscan IP [list PORT1 PORT2 ..] MAXCONNECTIONS TIMEOUT_IN_MS
# Ex: portscan 127.0.0.1 {80 8080 3128 22 21 23 119} 3 5000
# This MUST be called *[b]in/from[/b]* a coroutine
proc portscan {ip ports conns timeout} {
set myconns 0
set openports [list]
set notimeoutports [list]
foreach port $ports {
set s [socket -async $ip $port]
fileevent $s writable [list [info coroutine] [list $s $port open]]
after $timeout catch [list [list [info coroutine] [list $s $port timeout]]]
incr myconns
if {$myconns < $conns} {
continue
} else {
portscan_getfeedback
portscan_assignstate
}
}
while {$myconns} {
portscan_getfeedback
portscan_assignstate
}
return $openports
}
proc testscan {ip ports conns timeout} {
set openports [portscan $ip $ports $conns $timeout]
puts "Open ports: $openports"
exit 0
}
if {[llength $argv] != 4} {
puts "Syntax: $argv0 <ip> <port1,port2,..> <connections> <timeout in ms>"
puts "Ex: $argv0 127.0.0.1 80,3128,8080,22,23 2 2500"
exit 1
}
lassign $argv ip ports conns timeout
coroutine coro_789572 testscan $ip [split $ports ,] $conns $timeout
vwait forever
|
 |
This post was edited 2 times, last on 01-10-2011, 17:56 by thommey
|
 |
Topic: [TCL] Hexdump Forum: #tcl › code snippets Goto post |
thommey  | 08-09-2010, 16:58 | [TCL] Hexdump | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
proc Int2Hex {data} {
if {![string is digit -strict $data]} {return -1}
set str "0123456789abcdefghijklmnopqrstuvwxyz"; set text ""
set i [expr {$data & 15}]; set r [expr {$data / 16}]
set text [string index $str $i]
while {$r>0} {
set i [expr {$r & 15}]; set r [expr {$r / 16}]
set text "[string index $str $i]$text"
}
return $text
}
proc conv {text} {
foreach ch [split $text ""] {
if {[scan $ch %c]<27} {
set text [string map [list $ch [format %c [expr {[scan $ch %c]+64}]]] $text]
}
}
return $text
}
proc puthex {data {saddr 0}} {
set pos 0; set sw 0; set hex(0) ""; set hex(1) ""; set text(0) ""; set text(1) "";
while {[string length $data]>0} {
set spos [string range "0000[Int2Hex $pos]" end-3 end]
if {$saddr!=0} {
set stpos [string range "0000[Int2Hex [expr {$pos+$saddr}]]" end-3 end]
} {set stpos ""}
if {[string length $data]<8} {
set text($sw) $data
incr pos [string length $data]
binary scan $data H* hex($sw)
set data ""
} {
incr pos 8
binary scan $data H16 hex($sw)
set text($sw) [string range $data 0 7]
set data [string range $data 8 end]
}
set sw [expr {$sw^1}]
if {[string length $data]<8} {
set text($sw) $data
incr pos [string length $data]
binary scan $data H* hex($sw)
set data ""
} {
incr pos 8
binary scan $data H16 hex($sw)
set text($sw) [string range $data 0 7]
set data [string range $data 8 end]
}
set sw [expr {$sw^1}]
set txt(0) ""; foreach {ch0 ch1} [split $hex(0) ""] {append txt(0) "$ch0$ch1 "}; append txt(0) " "; set txt(0) [string range $txt(0) 0 22]
set txt(1) ""; foreach {ch0 ch1} [split $hex(1) ""] {append txt(1) "$ch0$ch1 "}; append txt(1) " "; set txt(1) [string range $txt(1) 0 22]
set text(0) [string range "[conv $text(0)] " 0 7]
set text(1) [string range "[conv $text(1)] " 0 7]
if {$stpos!=""} {
putcmdlog "0x$stpos | 0x$spos | $txt(0) | $txt(1) | $text(0) | $text(1)"
} {
putcmdlog "0x$spos | $txt(0) | $txt(1) | $text(0) | $text(1)"
}
set hex(0) ""; set hex(1) ""; set text(0) ""; set text(1) "";
}
}
|
puthex $message  |
 |
Topic: [Site] Paste site Forum: work › script announcements Goto post |
thommey  | 07-06-2010, 01:28 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| The warning is actually generated by pretty simple code (not even close to what would be required to do that perfectly) and shouldn't even be there anymore, we just disabled it after you report. (the automatic syntaxchecker is way more accurate and replaces the need for that). However, the same bit of code is responsible for colorizing pairs or {} and [] and thanks to your bugreport we fixed that.
The closing ] in the regular expression is now the same as the one before (it used to be black).
Thanks for your detailed report and tracking down this bug!  |
This post was edited 1 times, last on 08-27-2011, 01:22 by thommey
|
 |
Topic: [TCL] work with CS Server Forum: work › imminent problem solving Goto post |
thommey  | 05-21-2010, 04:26 | Jabber |
(Administrator) Member since 03/2004 62 Posts
|  |
 |
Topic: [EGG] Redirect errors to a channel/query Forum: #tcl › code snippets Goto post |
thommey  | 12-20-2009, 13:20 | [EGG] Redirect errors to a channel/query | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
########
# Set the errortarget <channel> or <nick>. Set to "" to disable.
set errortarget "#chan"
# Set this to 1 if you want error backtraces to be put to the logfiles, too
set logerrors 1
########
# Only trace once
if {![info exists ::errortracer]} {
set ::errortracer 1
trace add variable ::errorInfo write redirecterror
}
# Because of how errors are triggered in eggdrop and tcl,
# we need to prevent doubled/tripled errors happening at once.
# I use a 2-second delay here to do that
proc redirecterror {args} {
global errortarget logerrors lasterror errorInfo
if {![info exists logerrors] || [info exists lasterror] && $lasterror eq $errorInfo} { return }
if {$errortarget ne ""} {
puthelp "PRIVMSG $errortarget :Tcl-Error backtrace:"
foreach line [split $errorInfo \n] {
puthelp "PRIVMSG $errortarget :$line"
}
}
if {$logerrors} {
putlog "Tcl-Error backtrace: $errorInfo"
}
set lasterror $errorInfo
utimer 2 {catch {unset ::lasterror}}
}
|
 |
This post was edited 5 times, last on 02-26-2014, 23:32 by thommey
|
 |
Topic: [Site] Paste site Forum: work › script announcements Goto post |
thommey  | 11-06-2009, 02:27 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| I rarely touch that code, I haven't made any changes to that for almost two years (I just properly generated that patchfile, so I can update nagelfar but still keep my changes). I'll try to remember to change the paste above and post here that I updated it. (So having this thread on your watchlist should do). It's not worth putting that into a CMS   |
 |
Topic: [Site] Paste site Forum: work › script announcements Goto post |
thommey  | 10-27-2009, 13:41 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| I modified nagelfar to check for eggdrop's bind instead of Tk's bind.
(No one pastes Tk, ever, afaik  .
The full patch I applied to nagelfar is:
001
002
003
004
005
006
007
008
009
010
011
012
013
014
015
016
017
018
019
020
021
022
023
024
025
026
027
028
029
030
031
032
033
034
035
036
037
038
039
040
041
042
043
044
045
046
047
048
049
050
051
052
053
054
055
056
057
058
059
060
061
062
063
064
065
066
067
068
069
070
071
072
073
074
075
076
077
078
079
080
081
082
083
084
085
086
087
088
089
090
091
092
093
094
095
096
097
098
099
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
--- nagelfar.tcl 2009-07-19 19:18:25.421025665 +0200
+++ nagelfar.tcl 2009-10-27 13:36:48.181154390 +0100
@@ -24,10 +24,10 @@
# $Revision: 424 $
#----------------------------------------------------------------------
# the next line restarts using tclsh \
-exec tclsh "$0" "$@"
+exec tclsh8.5 "$0" "$@"
set debug 0
-package require Tcl 8.4
+package require Tcl 8.5
package provide app-nagelfar 1.0
set version "Version 1.1.9 2008-09-05"
@@ -132,9 +132,19 @@
}
}
+proc Text2Html {data} {
+ string map {\& \& \< \< \> \> \" \"} $data
+}
+
# Standard error message.
# severity : How severe a message is E/W/N for Error/Warning/Note
proc errorMsg {severity msg i} {
+ if {$::Prefs(html)} {
+ set msg [Text2Html $msg]
+ if {$msg == "Expr without braces"} { append msg " (see <a href=\"http://tclhelp.net/unb/194\" target=\"_tclforum\">http://tclhelp.net/unb/194</a>)" }
+ }
+ if {[string match debug* $msg]} { return 0 }
+
if {[info exists ::Nagelfar(currentMessage)] && \
$::Nagelfar(currentMessage) != ""} {
lappend ::Nagelfar(messages) [list $::Nagelfar(currentMessageLine) \
@@ -157,7 +167,15 @@
set pre "$::currentFile: "
}
set line [calcLineNo $i]
+
+ switch -exact -- $severity {
+ E { set color "#DD0000"; set severity "ERROR" }
+ W { set color "#FFAA00"; set severity "WARNING" }
+ N { set color "#66BB00"; set severity "NOTICE" }
+ }
set pre "${pre}Line [format %3d $line]: $severity "
+ if {$::Prefs(html)} { set pre "<a href=#$::Prefs(prefix)$line>Line [format %3d $line]</a>: <font color=$color><strong>$severity</strong></font>: " }
+
set ::Nagelfar(indent) [string repeat " " [string length $pre]]
set ::Nagelfar(currentMessage) $pre$msg
set ::Nagelfar(currentMessageLine) $line
@@ -180,6 +198,27 @@
set ::Nagelfar(commentbrace) {}
}
+proc sortmsgs {msg1 msg2} {
+ if {$msg1 == $msg2} { return 0 }
+ set htmlmask "href=#$::Prefs(prefix)(\\d+)>"
+ set normmask "Line\\s+(\\d+):"
+ if {![info exists ::sortRE]} {
+ if {$::Prefs(html)} { set ::sortRE $htmlmask } else { set ::sortRE $normmask }
+ # cache
+ regexp -- $::sortRE ""
+ }
+ regexp -- $::sortRE $msg1 -> line1
+#puts "Matching '$re' against '$msg1' -> [info exists line1]"
+ regexp -- $::sortRE $msg2 -> line2
+#puts "Matching '$re' against '$msg2' -> [info exists line2]"
+ if {![info exists line1] || ![info exists line2]} {
+ puts stderr "Could not sort messages! Wrong format! (html: $::Prefs(html))"; return -1
+ }
+ if {$line1 > $line2} { return 1 } else { return -1 }
+ return 0
+}
+
+
# Called after a file has been parsed, to flush messages
proc flushMsg {} {
if {[info exists ::Nagelfar(currentMessage)] && \
@@ -187,7 +226,8 @@
lappend ::Nagelfar(messages) [list $::Nagelfar(currentMessageLine) \
$::Nagelfar(currentMessage)]
}
- set msgs [lsort -integer -index 0 $::Nagelfar(messages)]
+# set msgs [lsort -integer -index 0 $::Nagelfar(messages)]
+ set msgs [lsort -unique -increasing -command sortmsgs $::Nagelfar(messages)]
foreach msg $msgs {
set text [lindex $msg 1]
set print 1
@@ -385,6 +425,7 @@
if {$i == -1} {
# This should never happen since no incomplete lines should
# reach this function.
+# puts "Unable to parse this line. Missing ' ' before '\{' perhaps? (Line [expr {$index + $i}])"
decho "Internal error: Did not find close char in scanWord.\
Line [calcLineNo $index]."
return $len
@@ -1591,6 +1632,7 @@
# If the command contains substitutions we can not determine
# which command it is, so we skip it, unless the type is known
# to be an object.
+
if {($cmdws & 1) == 0} {
if {[string match "_obj,*" $cmdtype]} {
set cmd $cmdtype
@@ -1630,6 +1672,7 @@
# have their own special check implemented here.
# Any command that can be checked by checkCommand should
# be in the syntax database.
+
switch -glob -- $cmd {
proc {
if {$argc != 3} {
@@ -1651,11 +1694,22 @@
parseProc $argv $indices
set noConstantCheck 1
}
- .* { # FIXA, check code in any -command.
- # Even widget commands should be checked.
- # Maybe in checkOptions ?
- return
- }
+ bind { # eggdrop bind!
+ if {$argc != 3 && $argc != 4} { WA; return }
+ foreach {type flags keyw cmd} $argv { break }
+ switch -exact -- [string tolower $type] {
+ load - unld - evnt - disc { set argnum 1 }
+ link - nkch - filt - need - wall - chon - choff { set argnum 2 }
+ sent - rcvd - note - act - bcst - chat - raw - bot - fil - away - dcc { set argnum 3 }
+ msg - msgm - splt - rejn - chpt - join { set argnum 4 }
+ flud - time - nick - notc - sign - topc - lost - tout - pub - pubm - part { set argnum 5 }
+ mode - ctcp - ctcr - chjn - kick { set argnum 6 }
+ default { errorMsg W "Unknown bind type: $type" $index; return }
+ }
+ set appendstr [string repeat " bla" $argnum]
+ append cmd $appendstr
+ parseBody $cmd [lindex $indices 3] knownVars
+ }
global {
foreach var $argv ws $wordstatus {
if {$ws & 1} {
@@ -2348,9 +2402,9 @@
if {$tmp != $closeBrace} {
# Only do this if there is a free open brace
if {[regexp "\{\n" $tryline]} {
- errorMsg N "Close brace not aligned with line\
- [calcLineNo $index] ($tmp $closeBrace)" \
- $closeBraceIx
+# errorMsg N "Close brace not aligned with line\
+# [calcLineNo $index] ($tmp $closeBrace)" \
+# $closeBraceIx
}
}
}
@@ -3626,6 +3680,7 @@
# Make next "E" error visible
proc seeNextError {} {
+
set w $::Nagelfar(resultWin)
set lineNo [lindex [split [$w index insert] .] 0]
@@ -4716,6 +4771,8 @@
editor internal
extensions {.tcl .test .adp .tk}
exitcode 0
+ html 0
+ prefix ""
}
# Do not load anything during test
@@ -4834,6 +4891,8 @@
-encoding <enc> : Read script with this encoding.
-filter <p> : Any message that matches the glob pattern is suppressed.
-severity <level> : Set severity level filter to N/W/E (default N).
+ -html : Generate html-output.
+ -prefix <pref> : Prefix for line anchors (html output)
-novar : Disable variable checking.
-WexprN : Sets expression warning level to N.
2 (def) = Warn about any unbraced expression.
@@ -5042,6 +5101,13 @@
exit
}
}
+ -html {
+ set ::Prefs(html) 1
+ }
+ -prefix {
+ incr i
+ set ::Prefs(prefix) [lindex $argv $i]
+ }
-tab {
incr i
set arg [lindex $argv $i]
@@ -5112,6 +5178,7 @@
}
doCheck
+
#_dumplogme
#if {[array size _stats] > 0} {
# array set _apa [array get _stats]
|
 |
 |
Topic: [Site] Paste site Forum: work › script announcements Goto post |
thommey  | 10-27-2009, 00:33 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Nothing special.
1
|
nagelfar.tcl -quiet -html -Welse0 -prefix l <file to test>
|
Where -html and -prefix are modifications to nagelfar so it generates html output suitable for integration into the pastesite (non-standard options).  |
This post was edited 1 times, last on 10-27-2009, 00:34 by thommey
|
 |
Topic: [EGG] Script to accept pastes via msg (w/coroutine example) Forum: #tcl › code snippets Goto post |
thommey  | 10-15-2009, 02:03 | [EGG] Script to accept pastes via msg (w/coroutine example) | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Without coroutines
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
set webdir "/home/public_www/tcl/"
set website "http://shell7.powershells.de/~tcl/"
bind msg - paste paste
proc paste {n u h t} {
global paste
set paste($n) ""
putserv "PRIVMSG $n :Ok, now you may paste your script. Use\"endpaste\" if you're finished."
return 1
}
bind msgm - * pasteapp
proc pasteapp {n u h t} {
global paste
if {![info exists paste($n)]} { return 0 }
if {$t == "paste" || $t == "endpaste"} { return 0 }
lappend paste($n) $t
}
bind msg - endpaste endpaste
proc endpaste {n u h t} {
global paste webdir website
if {![info exists paste($n)]} {
putserv "PRIVMSG $n :\"endpaste\" without \"paste\". Ignoring."
return 1
}
if {$paste($n) == ""} {
putserv "PRIVMSG $n :No text stored. Please retry."
return 1
}
regsub -nocase -- {[^a-zA-Z0-9|-]} $n {} n2
set fs [open [file join $webdir $n2.html] w]
puts $fs "<html><head><title>Paste on [clock format [clock seconds]] from $n</title></head><body>"
set cnt 1
foreach line $paste($n) {
regsub -all {\t} $line {\ \ \ \ } line
puts $fs "$cnt[str { } [expr {4 - [string length $cnt]}]] $line<br>"
incr cnt
}
puts $fs "</body></html>"
close $fs
unset paste($n)
putserv "PRIVMSG $n :$website$n2.html generated."
}
proc str {str tms} {
set res ""
for {set i 1} {$i <= $tms} {incr i} {
append res $str
}
return $res
}
|
With coroutines
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
set webdir "/home/public_www/tcl/"
set website "http://shell7.powershells.de/~tcl/"
bind msg - paste paste
proc paste {n u h t} {
if {[info commands coro_paste_$n] == ""} {
coroutine coro_paste_$n paste_template $n; # create the coroutine from the template
} else {
coro_paste_$n $t; # continue the existing coroutine for this user
}
}
proc paste_template {n} {
global webdir website
putserv "PRIVMSG $n :Ok, now you may paste your script. Use\"endpaste\" if you're finished."
regsub -nocase -- {[^a-zA-Z0-9|-]} $n {} n2
set fs [open [file join $webdir $n2.html] w]
puts $fs "<html><head><title>Paste on [clock format [clock seconds]] from $n</title></head><body>"
set linenr 0
# the yield here pauses and waits, returns the argument with which the coroutine is continued
while {[set text [yield]] != "endpaste"} {
regsub -all {\t} $text {\ \ \ \ } text
puts $fs "$linenr[str { } [expr {4 - [string length $linenr]}]] $text<br>"
incr linenr
}
puts $fs "</body></html>"
close $fs
putserv "PRIVMSG $n :$website$n2.html generated."
}
proc str {str tms} {
set res ""
for {set i 1} {$i <= $tms} {incr i} {
append res $str
}
return $res
}
|
 |
 |
Topic: [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth) Forum: #tcl › code snippets Goto post |
thommey  | 05-21-2009, 03:23 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Synchronous WHO Version ( TCL 8.6 required)
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
package require Tcl 8.6
bind raw - 354 who_info
bind raw - 315 end_of_who
bind pub - !auth who_pubcmd
proc who_pubcmd {nick host hand chan text} {
if {$text == ""} {
putserv "PRIVMSG $chan :Please specify a nickname"
return 0
}
set text [lindex [split $text] 0]
if {[info commands lookupwho_$text] ne ""} {
putserv "PRIVMSG $chan :Sorry, already resolving the auth for that nickname, wait"
return 0
}
coroutine lookupwho_$text lookupwho $text $chan
return 0
}
proc lookupwho {nick chan} {
putserv "WHO $nick n%na"
set auth [yield]
if {$auth eq ""} {
putserv "PRIVMSG $chan :$nick is not on the network."
} elseif {$auth eq "0"} {
putserv "PRIVMSG $chan :$nick is not authed."
} else {
putserv "PRIVMSG $chan :$nick is authed as $auth"
}
}
# ANSWER from server: End of /who - we got reply already?
proc end_of_who {from keyword text} {
set targetnick [lindex [split $text] 1]
if {[info commands lookupwho_$targetnick] ne ""} {
lookupwho_$targetnick ""
return 1
}
return 0
}
proc who_info {from keyword text} {
if {[llength [set text [split $text]]] != 3} {
return 0
}
set targetnick [lindex $text 1]
set auth [lindex $text 2]
if {[info commands lookupwho_$targetnick] ne ""} {
lookupwho_$targetnick $auth
return 1
# return 1: Eggdrop will not parse it, so you can use a format you like
}
return 0
}
|
 |
This post was edited 4 times, last on 01-08-2013, 18:44 by thommey
|
 |
Topic: [EGG] Join/Part a channel and spy out (aka Bot-Request) Forum: #tcl › code snippets Goto post |
thommey  | 02-05-2009, 22:31 | Tcl8.6 coroutine-solution: | Jabber |
(Administrator) Member since 03/2004 62 Posts
| REQUIRES Tcl8.6!
Works without the use of global variables
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
package require Tcl 8.6
bind pub m !spychannel spychannel:init
proc spychannel:init {nick host hand chan text} {
set channel [string tolower [lindex [split $text] 0]]
if {[info commands spychannel_$channel] ne ""} {
putserv "PRIVMSG $chan :Request already in progress for $channel"
return 0
}
# init coroutine
coroutine spychannel_$channel spychannel $nick $host $hand $chan $text
return 1
}
proc spychannel {nick host hand chan text} {
if {[set channel [lindex [split $text] 0]] == "" || [string index $channel 0] != "#"} {
putserv "PRIVMSG $chan :Syntax: $::lastbind <#channel>"
return 0
}
channel add $channel
# pause the current procedure (to wait for raw 315)
yield
putserv "PRIVMSG $chan :Hey $nick, on $channel are [llength [chanlist $channel]] users. Modes are: [getchanmode $channel]."
channel remove $channel
}
#315 <botnick> <chan> :End of /WHO list.
bind raw - 315 spychannel:eow
proc spychannel:eow {from key text} {
set channel [lindex [split $text] 1]
if {[info commands spychannel_$channel] ne ""} {
# continue existing coroutine
spychannel_$channel
}
return 0
}
|
 |
This post was edited 4 times, last on 10-15-2009, 00:53 by thommey
|
 |
Topic: [TCL] Trace open file handles (to get the filename from an open filesocket) Forum: #tcl › code snippets Goto post |
thommey  | 06-15-2008, 10:02 | [TCL] Trace open file handles (to get the filename from an open filesocket) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
bind dcc n fileinfo tellfileinfo
proc tellfileinfo {hand idx text} {
if {$text eq ""} {
foreach f [file channels] {
if {![string match file* $f]} { continue }
catch {tellfileinfo $hand $idx $f}
}
} else {
set f $text
putdcc $idx "Filesock $f -> [file normalize [handle2file $f]]. Opened by \[[handle2opener $f]\]"
}
}
if {![info exists ::opentrace]} {
# add the 2 traces. one to 'open', one to 'close'.
trace add execution open leave tracer_open
trace add execution close leave tracer_close
set ::opentrace 1
}
#procedure to lookup <socket> to <filename> (or commandname if piped)
# Usage: handle2file fileXXXX
# Example: "handle2file [open randomfile w]" should return "randomfile"
# (close the file afterwards :)
proc handle2file {handle} {
if {![info exists ::openfiles($handle)]} {
error "File handle not found"
} else {
return [lindex $::openfiles($handle) 0]
}
}
#procedure to lookup <socket> to <procedure which initially called open>
proc handle2opener {handle} {
if {![info exists ::openfiles($handle)]} {
error "File handle not found"
} else {
return [lindex $::openfiles($handle) 1]
}
}
# tracer_open "open <filename> ?mode?" 0/1 "file..." leave
proc tracer_open {cmdstr rescode resstr op} {
# there was an error, file wasn't really opened
if {$rescode} { return }
# check if it was a filesocket
if {[string match file* $resstr]} {
# add handle with corresponding filename to array
if {[catch {info level -1} caller]} { set caller -global- }
set ::openfiles($resstr) [list [lindex [split $cmdstr] 1] $caller]
}
}
# tracer_close "close <handle>" 0/1 "" leave
proc tracer_close {cmdstr rescode resstr op} {
set handle [lindex [split $cmdstr] 1]
# there was an error or I don't know about that handle
if {$rescode || ![info exists ::openfiles($handle)]} { return }
# remove handle from array
unset ::openfiles($handle)
}
|
 |
This post was edited 4 times, last on 09-26-2010, 03:14 by thommey
|
 |
Topic: convert mirc script to tcl Forum: work › imminent problem solving Goto post |
thommey  | 06-03-2008, 18:36 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Why did you paste a reply to http://paste.tclhelp.net/?id=cec?
Why did you change "msgm" to "msg"? Msgm was correct. You can't just guess...
http://paste.tclhelp.net/?id=cec works now (my reply, the top one)
And just yelling "doesn't work" didn't help a single bit. You could at least describe what happens and if you see error messages in partyline. The snippet worked one-way at least.  |
 |
Topic: Any feature suggestions/recommendations? Forum: #tcl › smalltalk Goto post |
thommey  | 04-11-2008, 01:20 | Any feature suggestions/recommendations? | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Hi,
I'm currently developing a patch for eggdrop to see through ircu's +D (delayed joins) which currently has the following features:
- trigger bind join/bind nick/bind part for invisible users (checks list every minute)
- provide the tcl command "getchanlogin nick ?channel?" which returns the login (AC Token, Q/X-Auth) for the user (0 if not logged in. "" if not yet known). cached for all users on the bots channels
- provide the tcl command "isloggedin nick ?channel?" returning 1 if the user is authed, 0 if not or not found
- provide the tcl command "getchanrealname nick ?channel?" returning the realname of a user (or "" if unknown/user not found)
- provide the tcl command "isinvisible nick ?channel?" returns 1 if the user is invisible on the channel (or any channel if unspecified), 0 otherwise.
When a user joins being invisible I know the login and realname instantly, so..
1
2
|
bind join - * bla
proc bla {n u h c} { putmsg $c "Hi $n (authed as [getchanlogin $n $c]) with realname '[getchanrealname $n $c]' }
|
will work perfectly for invisible users.
But for visible joins, it knows neither the realname nor the auth onjoin.
What I'm thinking about now is:
Would it be useful to add a (channel-)setting to delay the join-binds until this information is known? (worst case: 1 minute after join)
Should I refresh more than every minute? (I add a queue with lowest priority (< help), so you won't notice it anyway)
Should I add tcl binds for when the information is known or a user authes? Or both? (such as 'bind info' passing 'nick host hand chan login realname' and/or 'bind auth' passing 'nick host hand chan login')
It would be great if you could recommend/comment on those matters (especially the last one is of importance at the moment)
Thanks,
thommey  |
 |
Topic: [EGG] TV Script (German stations) (Beschreibung is im Text..) Forum: work › script announcements Goto post |
thommey  | 03-06-2008, 01:23 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Die eigentliche Ausführung von cachetvdata dauert ziemlich lange, versuchs morgen nochmal, es sollte dann gehen  |
 |
Topic: [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth) Forum: #tcl › code snippets Goto post |
thommey  | 07-20-2007, 22:30 | Synchronous (Blocking) attempt | Jabber |
(Administrator) Member since 03/2004 62 Posts
| THIS IS A DEPRECATED HACK AND SHOULD NOT BE USED. SCROLL DOWN FOR PROPER SYNCHRONOUS ATTEMPTS
Due to popular demand for the most-obvious and intuitive approach, I wrote the following solution:
How to use it in your code?
1
2
3
4
5
|
bind pub - !test test
proc test {nick host hand chan text} {
set qauth [getqauth $nick]
putserv "PRIVMSG $chan :$nick, dein auth ist $qauth (0 = nicht geauthed)"
}
|
This also works for users not on the bot's channels!
Keep in mind that this method may take a few seconds and block your bot!
And here is how it works:
You need 2 Bots for it.
Bot1 is the one you want to use [getqauth] on.
Bot2 is the slave-bot getting the Q-authes.
You have to put this somewhere on your shell of Bot1 (as a textfile..) (I made it /home/tcl/getqauth.tcl but it doesnt matter)
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
|
#!/usr/bin/tclsh
# CONFIGURE ME! IP/Host of Bot2 !!!
set remotehost 127.0.0.1
# CONFIGURE ME! Port of Bot2 !!!
set remoteport 4756
set nick [lindex $argv 0]
if {$nick == ""} { puts "Syntax: $argv0 <nickname>"; exit 1 }
set sid [socket $remotehost $remoteport]
fconfigure $sid -buffering line -blocking 1
puts $sid $nick
set auth ""
while {$auth == ""} {
gets $sid auth
set auth [string trim $auth]
}
puts $auth
exit 0
|
Then, bot1 has to load this script:
01
02
03
04
05
06
07
08
09
10
|
# CONFIGURE ME: The absolute path to the file you just created (the textfile from above)
set path_to_exfile /home/user/eggdrop/qauth.tcl
# CONFIGURE ME: Path to tclsh executable (most likely you dont need to change it)
set path_to_tcl /usr/bin/tclsh
proc getqauth {nick} {
set auth [exec $::path_to_tcl $::path_to_exfile $nick]
return $auth
}
|
Last but not least, Bot2 has to load this script:
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
|
# CONFIGURE ME! Port to listen on (Remember to change it in the other file as well)
set ::qport 4756
if {![info exists ::qauthlisten]} { set ::qauthlisten [socket -server qauthacc $::qport] }
proc qauthacc {cid ip port} {
putlog "Q-Auth: Incoming connection ($cid) from $ip:$port"
fconfigure $cid -buffering line -blocking 0
fileevent $cid readable "qread $cid"
}
proc qread {cid} {
if {[gets $cid req] < 0} { putlog "$cid closed."; catch {close $cid} }
set req [string trim $req]
set req [string tolower $req]
if {$req == ""} { return }
set hash [expr {[rand 900]+100}]
if {[info exists ::qcallback($req)]} {
lappend ::qcallback($req) $cid
} else {
set ::qcallback($req) $cid
}
putquick "WHO $req n%nat,734"
}
bind raw - 354 qcall
bind raw - 315 qend
proc qcall {f k t} {
set t [string tolower $t]
foreach {bn num nick auth} [split $t] break
if {$num != 734} { return 0 }
if {![info exists ::qcallback($nick)]} { return 1 }
sendresult $nick $auth
return 1
}
proc sendresult {nick auth} {
foreach sid $::qcallback($nick) {
puts $sid $auth; utimer 5 [list catch [list close $sid]]
}
unset ::qcallback($nick)
}
proc qend {f k t} {
set t [string tolower $t]
foreach {bn nick} [split $t] break
if {![info exists ::qcallback($nick)]} { return 0 }
sendresult $nick -1
return 1
}
|
That's it.
Additional information:
[getqauth $nick] returning "-1" means: nick is not on the network (are your bots on the same network?  )
[getqauth $nick] returning "0" means: nick is not authed
P.S.: You can, of course, cross-use it (files of bot1 copied and properly loaded to bot2 and vice versa) to make both bots able to use each other to retrieve authes  |
This post was edited 3 times, last on 05-21-2009, 03:22 by thommey
|
 |
Topic: [TCL] Synchronized high resolution timestamp Forum: #tcl › code snippets Goto post |
thommey  | 02-27-2007, 23:49 | [TCL] Synchronized high resolution timestamp | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
# This returns the current seconds of the timestamp
proc secs {} { clock format [clock seconds] -format %S }
# Because clock clicks are asynchronous, we need to check at what [clock clicks] seconds usually switch. So we do that here:
proc getsecswitch {} {
set s [secs]
while {$s == [secs]} { update }
return [string range [clock clicks] end-5 end-3]
}
# That won't change while the interpreter is still running (CPU running)
set ::secswitch [getsecswitch]
proc getms {} {
return [string range [expr {[clock clicks] - $::secswitch * 1000}] end-5 end-3]
}
# Example of usage:
proc timestamp {} {
return "[clock format [clock seconds] -format %H:%M.%S]`[getms]"
}
# Verify that it's working
set s [secs]
while {$s == [secs]} { update }
if {[string range [getms] 0 1] != "00"} {
# "Warning! High precision clock doesn't work as it should!"
}
if {[string index [getms] end] != "0"} {
# "High precision clock works doesn't work with highest precision (<10ms difference)"
}
# "High precision clock set up and working perfectly."
|
 |
This post was edited 2 times, last on 02-17-2008, 14:31 by thommey
|
 |
Topic: help to convert (from mrc file to tcl) Forum: eggdrop › help Goto post |
thommey  | 10-25-2006, 17:04 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| please show us then what you got so far  |
 |
Topic: help to convert (from mrc file to tcl) Forum: eggdrop › help Goto post |
thommey  | 10-24-2006, 16:34 | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
1
2
3
4
5
6
|
bind ctcp - ACTION someaction
proc someaction {nick host hand dest key text} {
if {[string match {* cm *} $text]} {
putserv "PRIVMSG #channel :$nick text: $text"
}
}
|
 |
 |
Topic: [EGG] TV Script (German stations) (Beschreibung is im Text..) Forum: work › script announcements Goto post |
thommey  | 10-15-2006, 18:54 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Die senderliste im Script hat keinen Einfluss auf das Suchergebnis. Um nur in Hauptsendern zu suchen musst du im folgenden script-teil
Something failed while rendering code in this thread, please inform #tcl on QuakeNet. Thank you.
die vorletzte Zeile:
1
|
set tok [http::geturl $url -query [http::formatQuery "allgemein\[titel]" $maske no_cache 1] -timeout 5000]
|
ändern in:
1
|
set tok [http::geturl $url -query [http::formatQuery "allgemein\[titel]" $maske no_cache 1 "tv\[sender]" A] -timeout 5000]
|
Dann sucht er nur in Hauptsendern.  |
 |
Topic: [EGG] Parsing and/or changing mode-strings (as in chanset chanmode) Forum: #tcl › code snippets Goto post |
thommey  | 10-03-2006, 18:21 | [EGG] Parsing and/or changing mode-strings (as in chanset chanmode) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
# converts a modestring into a modelist (eg. "+ack-bl key" => {{+a} {-b} {+c} {+k key} {-l}})
proc splitmodes {mstr} {
set key ""; set limit ""; set pre +; set result [list]
foreach {modes param1 param2} [split $mstr] break
foreach chr [split $modes ""] {
if {$chr == "+"} { set pre +; continue }
if {$chr == "-"} { set pre -; continue };
if {$chr == "k" && $pre == "+"} {
lappend result "$pre$chr $param1"; set param1 $param2; continue
} elseif {$chr == "l" && $pre == "+"} {
lappend result "$pre$chr $param1"; set param1 $param2; continue
}
lappend result $pre$chr
}
return $result
}
# converts a modelist into a modestring (eg. {{+a} {-b} {+c} {+k key} {-l}} => "+ack-bl key")
proc joinmodes {mlist} {
set plus [list]
set minus [list]
set param1 ""
set param2 ""
foreach modestr $mlist {
foreach {md param} [split $modestr] break
foreach {pre mode} [split $md ""] break
set list plus
if {$pre == "-"} { set list minus }
if {$mode == "k" || $mode == "l"} { if {$param1 == ""} { set param1 $param } { set param2 $param} }
lappend $list $mode
}
if {![llength $plus]} { set plusstr "" } { set plusstr "+[join $plus ""]" }
if {![llength $minus]} { set minusstr "" } { set minusstr "-[join $minus ""]" }
set paramstr ""
if {$param1 != ""} { set paramstr " $param1" }
if {$param2 != ""} { set paramstr " $param1 $param2" }
return $plusstr$minusstr$paramstr
}
# changes a modestring depending on the second modestring
# (zB "+nkt-m key" "-k+m" => "+ntm-k")
proc changemodes {oldmodes newmodes} {
set oldmodes [splitmodes $oldmodes]
set newmodes [splitmodes $newmodes]
foreach md $newmodes {
foreach {md2 param} [split $md] break
foreach {pre mode} [split $md2 ""] break
if {$pre == "+"} { set remove "-" }
if {$pre == "-"} { set remove "+" }
# delete the old
if {[set pos [lsearch -glob $oldmodes "$remove$mode*"]] != -1} {
set oldmodes [lreplace $oldmodes $pos $pos]
}
# add the new
if {$param == ""} { lappend oldmodes $pre$mode } { lappend oldmodes "$pre$mode $param" }
}
return [joinmodes $oldmodes]
}
|
 |
 |
Topic: [TCL] Socket examples (Simple Server and Client socket in plain TCL) Forum: #tcl › code snippets Goto post |
thommey  | 09-25-2006, 23:10 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Simple Client-Socket (connection to an IRC-Server here)
01
02
03
04
05
06
07
08
09
10
11
12
13
14
|
proc readdata {cid} {
if {[gets $cid data] < 0} {
puts "Socket closed by remote host."; close $cid; return
}
puts "Incoming data: $data"
if {[lindex [split $data] 0] == "PING"} {
puts $cid "PONG [lindex [split $data] 1]"
}
}
set sid [socket irc.quakenet.org 6667]
fconfigure $sid -buffering line
fileevent $sid readable "readdata $sid"
puts $sid "NICK hauth"
puts $sid "USER hauth * * :hauth"
|
 |
This post was edited 1 times, last on 09-07-2009, 21:51 by thommey
|
 |
Topic: [TCL] Socket examples (Simple Server and Client socket in plain TCL) Forum: #tcl › code snippets Goto post |
thommey  | 09-17-2006, 23:34 | [TCL] Socket examples | Jabber |
(Administrator) Member since 03/2004 62 Posts
| A s[ai]mple server socket
01
02
03
04
05
06
07
08
09
10
11
12
13
14
|
set listenport 8749
socket -server accept_connection $listenport
proc accept_connection {cid ip port} {
puts "Incoming Connection from $ip:$port"
fconfigure $cid -buffering line
fileevent $cid readable "readdata $cid"
}
proc readdata {cid} {
if {[gets $cid data] < 0} {
puts "Socket closed by remote host."; close $cid; return
}
puts "Incoming data: $data"
}
|
 |
This post was edited 3 times, last on 09-07-2009, 21:49 by thommey
|
 |
Topic: Why you should use braces {} around expressions. Forum: #tcl › smalltalk Goto post |
thommey  | 09-14-2006, 20:06 | Warum man geschweifte Klammern {} um expressions benutzen sollte. | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Als Erstes möchte ich mal klar stellen, dass es 2 häufige Vorkommnisse gibt, in denen expressions vorkommen.
Fall 1: expr (das offensichtliche)
1
|
proc multipliziere {a b} { return [expr $a * $b] }
|
Fall 2: If-Bedingung. Vielleicht weiß man es schon, oder nicht. If-Bedingungen werden mit expr ausgewertet. Das ist auch der Grund, warum überhaupt solche Bedingungen wie {1 + $var < 5} möglich sind.
1
|
if {$a * $b == 10} { puts "Ok" }
|
Als ihr die TCL Syntax gelernt habt, habt ihr vermutlich diese geschweiften Klammern einfach mit der Syntax auswendig gelernt und es übernommen.
Nach einiger Übung könnte man aber eventuell darauf gekommen sein, sie wegzulassen.
Die If-Bedingung:
1
|
if {[string is integer $a]} { .. }
|
macht ja scheinbar das gleiche wie
1
|
if [string is integer $a] { .. }
|
aber das tut sie NICHT.
Jetzt werde ich erklären, warum man {} benutzen sollte, sowohl um die If-Bedingung, als auch um das Argument an expr.
Was ist also der Sinn und Zweck der Klammern?
Ich gehe davon aus, dass ihr bereits den Unterschied zwischen set a "hallo $var" und set a {hallo $var} kennt. Letzteres setzt die Variable 'a' auf den Wert: "hallo $var", aber im ersten Fall wird $var durch den tatsächlichen Variableninhalt ersetzt.
Diese Ersetzung kostet Zeit und führt auch zu einer Doppel-Auswertung.
Ein Beispiel:
1
|
set a 4; set b 2; puts [expr $a*$b] ---> "8"
|
Something failed while rendering code in this thread, please inform #tcl on QuakeNet. Thank you.
Aber warum? Weil expr das Argument erneut verarbeitet/auswertet!
expr ersetzt Variablen durch ihren Inhalt ($var)
expr ersetzt Funktionen durch ihren Return-Wert ([command])
expr ersetzt Backslash-Schreibweisen durch ihre Werte (\n oder x84)
Wie ich oben bereits gesagt habe, das kostet ZEIT. expr {$a * $b} _ ist_ schneller. Weil der Interpreter nicht erst "$a * $b" durch "2 * 4" ersetzt, und dann anschließend expr erneut guckt, ob etwas zu ersetzen ist.
Aber es gibt noch ein viel größeres Problem als Rechenzeit ..(wer schnelle Rechenzeit braucht, benutzt sowieso nicht unbedingt TCL
Die SICHERHEIT!
Folgendes Beispiel nochmal:
1
|
proc multipliziere {a b} { return [expr $a*$b] }
|
and we call it like:
multipliziere 2 4 -> 8
multipliziere "\[exit\]" 4 -> EXIT
Tcl wird sich beenden. Weil expr den Inhalt wieder auswertet.
Also:
1
|
proc multipliziere {a b} { return [expr {$a * $b}] }
|
ist schneller und hat KEINE Sicherheitslücken im Gegensatz zur alten Version.
Deswegen schlägt unser Syntaxchecker alarm wenn keine Klammern da sind.
MAN SOLLTE expr {.....} NUTZEN, WENN MAN NICHT WIRKLICH DIE DOPPELAUSWERTUNG BRAUCHT.
(für kürzere Rechenzeit und vor allem zur Vermeidung der bekannten [die]-Bugs)
Weitere Informationen: http://wiki.tcl.tk/10225 |
This post was edited 4 times, last on 09-30-2006, 12:33 by thommey
|
 |
Topic: Why you should use braces {} around expressions. Forum: #tcl › smalltalk Goto post |
thommey  | 09-14-2006, 19:50 | Why you should use braces {} around expressions. | Jabber |
(Administrator) Member since 03/2004 62 Posts
| German translation: Scroll down!
First of all you should be aware that 2 common cases fit the statement "expression".
Case 1: expr (the obvious one)
1
|
proc multiply {a b} { return [expr $a * $b] }
|
Case 2: If-condition. If-conditions are evaluated similar to "expr". That's the reason you can use mathematic expressions (1 + $var < 5) in the if-condition:
1
|
if {$a * $b == 10} { puts "Ok" }
|
When you learned the Tcl syntax, you usually place these braces around "$a*$b==10" in the if condition just because it's the thing you've read in the manual and other languages aren't as simple as Tcl syntaxwise. So in other language you usually just learn the if-syntax by heart.
Maybe you already found out, that you can drop them. The statement:
1
|
if {[string is integer $a]} { .. }
|
apparently does the same as
1
|
if [string is integer $a] { .. }
|
but it doesn't.
Now let's get to the reason you most like want to use if {..} and expr {..}.
Why {} around the statement? What's the difference?
In Tcl, {} group words like "" do, but they prevent substitution of variables, command and backslash-expressions. Compare set a "hello $var" and set a {hello $var} for example. The latter will return "hello $var" but in the first one $var will be replaced by its content. Read more in the Tcl syntax definition (Rule 4,6)
This takes time and causes the statement to get double-evaluated.
Now we apply that logic to expr:
1
|
set a 4; set b 2; puts [expr $a*$b] ---> "8"
|
1
|
set a 4; set b 2; puts [expr {$a*$b}] ---> "8".. note: it does NOT return "$a*$b" but "8"!
|
But why? Because expr evaluates its argument(s)!
expr replaces variables by its values ($var)
expr replaces commands by its values ([command])
expr replaces substitutions by its values (\n or x84)
just like enclosing an argument in double quotes would.
As I already mentioned above, this takes time. expr {$a * $b} is faster, because with expr $a * $b, the interpreter replaces $a and $b by their values, passes "2 * 4" to expr, and expr then evaluates this. Expr can do that faster if it doesn't attempt to substitute variables/commands/... another time.
But there's a much more severe problem than the evaluation time... (which usually doesn't matter that much in network applications anyway)
The security.
Imagine the following proc again:
1
|
proc multiply {a b} { return [expr $a*$b] }
|
and we call it like:
multiply 2 4 -> 8
multiply {[exit]} 4 -> EXIT
Tcl will exit. Because expr evaluates the content {[exit] * 4} itself again, replacing [exit] by the return value of evaluating the command exit.
So, in fact:
1
|
proc multiply {a b} { return [expr {$a * $b}] }
|
is faster and prevents security holes which the other version has!
That's why our syntax checker in our pastebin complains about it.
YOU SHOULD USE expr {.....}, unless you need the double-evaluation (rare but possible).
(for computation time improvement and common [die]/[exit]-bug prevention)
See also: http://wiki.tcl.tk/10225  |
This post was edited 6 times, last on 08-02-2010, 12:48 by thommey
|
 |
Topic: [EGG] strip control codes (bold/underline/color) & Generic message handler to deal with chanmode +c Forum: #tcl › code snippets Goto post |
thommey  | 09-05-2006, 21:46 | [EGG] Generic message handler to deal with chanmode +c (strip control codes) | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Requires at least eggdrop1.6.17
1
2
3
4
5
6
|
proc safemsg {dest text {queue "help"} {extra "-normal"}} {
if {[validchan $dest] && [botonchan $dest] && [string first c [lindex [split [getchanmode $dest]] 0]] != -1} {
set text [stripcodes bcruag $text]
}
put$queue "PRIVMSG $dest :$text" $extra
}
|
Usage:
safemsg $chan "hello \002bold\002 \0034red\003"
(that will do puthelp)
safemsg $chan "hello \002bold\002 \00312 blue \003" serv
(that will do putserv)
safemsg $chan "hello \002bold\002" help -next
(will send the message as puthelp message but on top of the queue (or use 'quick' instead of 'help')
You can also use nicks of course, even if there's no +c possible
safemsg $nick "hello\002bold\002"
(but it wont remove control codes of course, because there is no +c on querys)  |
This post was edited 4 times, last on 09-05-2006, 21:56 by thommey
|
 |
Topic: [EGG] Make the bot establish a dcc-chat to me (like /ctcp <bot> chat) Forum: #tcl › code snippets Goto post |
thommey  | 08-27-2006, 20:23 | [EGG] Make the bot establish a dcc-chat to me (like /ctcp <bot> chat) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
1
2
3
4
5
6
7
|
proc 1 {} { format %c 1 }
foreach portlist [dcclist TELNET] {
if {([lindex $portlist 1] == "(all)") || ([lindex $portlist 1] == "(users)") || ([lindex $portlist 1] == "(telnet)")} {
set port [lindex [lindex $portlist 4] 1]; break
}
}
puthelp "PRIVMSG $nick :[1]DCC CHAT chat [myip] $port[1]"
|
 |
This post was edited 1 times, last on 12-01-2010, 00:38 by thommey
|
 |
Topic: [EGG] Splitting long text into smaller parts for IRC output Forum: #tcl › code snippets Goto post |
thommey  | 03-05-2006, 14:36 | The same, just a bit more complicated (tries to output complete sentences and adds - if it is necessary to split a word) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
proc safesay {dest text {queue putserv} {action PRIVMSG}} {
set action [string toupper $action]
set hardlimit 510
set prefix ":$::botname PRIVMSG $dest :"
incr hardlimit -[string length $prefix]
set softlimit $hardlimit
incr softlimit -100
if {[lsearch -exact {putserv puthelp putquick} $queue] == -1} {
error "bad queue \"$queue\": must be putserv, puthelp or putquick"
}
if {[lsearch -exact {PRIVMSG NOTICE} $action] == -1} {
error "bad action \"$action\": must be PRIVMSG or NOTICE"
}
set temp [list]
set ::text65 $text
while {[string length [join $::text65]]} {
$queue "$action $dest :[getoneline ::text65 $softlimit $hardlimit]"
}
}
proc lowest {list} {
foreach e $list {
if {![info exists min]} { set min $e; continue }
if {$e < $min && $e != -1} { set min $e }
}
return $min
}
proc getoneline {varname softlimit hardlimit} {
set $varname [split [set $varname]]; set textnew [set $varname]
set temp [list]; set tempnew [list]
# temp contains the text to send
if {[string length [lindex [set $varname] 0]] >= $hardlimit} {
set temp "[string range [set $varname] 0 [expr $hardlimit - 2]]-"
set $varname [string range [set $varname] [expr $hardlimit - 1] end]
return $temp
}
while {[string length [join $tempnew]] < $softlimit && [string length [set $varname]]} {
# as long as we're shorter than $softlimit, append
set $varname $textnew
set temp $tempnew
# $tempnew and $textnew are set in the next iteration. they're set delayed 1 cycle to catch the text _before_ we exceed the limit
# so we clearly stay lower then the limit here
lappend tempnew [lindex [set $varname] 0]
set textnew [lrange [set $varname] 1 end]
}
# we're longer than $softlimit and are trying to finish the sentence by finding punctuations
set s1pos [lsearch -glob [set $varname] *.]
set s2pos [lsearch -glob [set $varname] *\\?]
set s3pos [lsearch -glob [set $varname] *,]
set s4pos [lsearch -glob [set $varname] *!]
set lowest [lowest [list $s1pos $s2pos $s3pos $s4pos]]
set tempnew $temp; set textnew [set $varname]
if {$lowest != -1} {
while {$lowest > -1 && [string length [set $varname]]} {
set tempnew [concat $temp [lrange [set $varname] 0 $lowest]]; incr lowest
set textnew [lrange [set $varname] $lowest end]
set s1pos [lsearch -glob $textnew *.]
set s2pos [lsearch -glob $textnew *\\?]
set s3pos [lsearch -glob $textnew *,]
set s4pos [lsearch -glob $textnew *!]
set lowest [lowest [list $s1pos $s2pos $s3pos $s4pos]]
if {[string length [join $tempnew]] < $hardlimit} {
set temp $tempnew
set $varname $textnew
} else { break }
}
return [join $temp]
}
# no punctuations :(
set textnew [set $varname]; set tempnew $temp
while {[string length [join $tempnew]] < $hardlimit && [string length [set $varname]]} {
# shorter than $softlimit, append words
set $varname $textnew
set temp $tempnew
# $tempnew and $textnew set delayed as above
lappend tempnew [lindex [set $varname] 0]
set textnew [lrange [set $varname] 1 end]
}
return [join $temp]
}
|
 |
This post was edited 4 times, last on 09-12-2010, 22:34 by thommey
|
 |
Topic: [TCL] Round a number (5.55 => 5.6 instead of 5.5 as 'format %.2f' would do it) Forum: #tcl › code snippets Goto post |
thommey  | 03-04-2006, 22:08 | [TCL] Round a number (5.55 => 5.6 instead of 5.5 as round() would do it) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
1
2
3
|
proc round {number {digits 0}} {
return [expr {round(pow(10,$digits)*$number)/pow(10,$digits)}]
}
|
 |
 |
Topic: [EGG] Botnick as trigger (<botnick> do something) Forum: #tcl › code snippets Goto post |
thommey  | 05-26-2005, 21:03 | [EGG] Botnick as trigger (<botnick> do something) | Jabber |
(Administrator) Member since 03/2004 62 Posts
| It is a bad idea to use
1
|
bind pub - $::botnick ..
|
or similar, as the $::botnick variable is not known on startup (only on connect). And it can change which will not result in an automatic unbind and re-bind.
So we bind on * (everything) and check if the first word is our nick. Then we use switch (looks better) to determine the commands.
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
|
bind pubm - * triggercheck
proc triggercheck {nick host hand chan text} {
set word1 [lindex [split $text] 0]
set cmd [lindex [split $text] 1]
set rest [join [lrange [split $text] 2 end]]
if {![isbotnick $word1]} { return }
switch -exact -- [string tolower $cmd] {
"op" {
if {![matchattr $hand o|o $chan]} { putserv "PRIVMSG $chan :No access"; return }
if {![onchan $rest $chan]} { putserv "PRIVMSG $chan :$rest is not here"; return }
putserv "MODE $chan +o $rest"
}
"voice" {
if {![matchattr $hand o|o $chan]} { putserv "PRIVMSG $chan :No access"; return }
if {![onchan $rest $chan]} { putserv "PRIVMSG $chan :$rest is not here"; return }
putserv "MODE $chan +v $rest"
}
default {
putserv "PRIVMSG $chan :Unknown command: $cmd"
}
}
}
|
Usage:
BotNick op someone
BotNick voice someone  |
This post was edited 1 times, last on 08-12-2009, 22:13 by thommey
|
 |
Topic: [EGG] Join/Part a channel and spy out (aka Bot-Request) Forum: #tcl › code snippets Goto post |
thommey  | 05-26-2005, 19:27 | [EGG] Join/Part a channel and spy out (aka Bot-Request) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
|
bind pub m !spychannel spychannel:init
proc spychannel:init {nick host hand chan text} {
if {[set channel [string trim [lindex [split $text] 0]]] == "" || [string index $channel 0] != "#"} {
putserv "PRIVMSG $chan :Syntax: $::lastbind <#channel>"
return 0
}
channel add $channel
set ::request_from_chan($channel) $chan
set ::request_from_nick($channel) $nick
return 1
}
#315 <botnick> <chan> :End of /WHO list.
bind raw - 315 spychannel:eow
proc spychannel:eow {from key text} {
set channel [lindex [split $text] 1]
if {![info exists ::request_from_chan($channel)]} {
return 0
}
putserv "PRIVMSG $::request_from_chan($channel) :Hey $::request_from_nick($channel), on $channel are [llength [chanlist $channel]] users. Modes are: [getchanmode $channel]."
unset ::request_from_chan($channel)
unset ::request_from_nick($channel)
channel remove $channel
return 0
}
|
 |
 |
Topic: [msl/TCL] Basic introduction Forum: #tcl › code snippets Goto post |
thommey  | 05-24-2005, 22:49 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| correct, I've corrected it  |
 |
Topic: [EGG] Dns Lookups (with variable-passing) Forum: #tcl › code snippets Goto post |
thommey  | 05-24-2005, 22:45 | [EGG] Dns Lookups (with variable-passing) | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
|
bind pub - !dns dns
proc dns {nick host hand chan text} {
set query $text
dnslookup $query dns_callback $chan $nick $query
}
proc dns_callback {ip addr state chan nick query} {
if {!$state} {
putserv "PRIVMSG $chan :\002$nick\002, failed to look up \002$query\002"
return
}
if {$query == $ip} {
putserv "PRIVMSG $chan :\002$nick\002 $ip->$addr"
} else {
putserv "PRIVMSG $chan :\002$nick\002 $addr->$ip"
}
}
|
 |
This post was edited 1 times, last on 08-12-2009, 22:12 by thommey
|
 |
Topic: [EGG] Random line from a file Forum: #tcl › code snippets Goto post |
thommey  | 03-31-2005, 12:33 | [EGG] Random line from a file | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
|
# Returns a random line out of $file (error if it doesnt exist)
proc randline {file} {
set fs [open $file r]
set data [read $fs]
close $fs
# Now we have the complete content of $file stored in $data
set data [split $data \n]
# Now it's a list of lines, and we use eggdrop's "rand" function to get a random element from it (and return it)
return [lindex $data [rand [llength $data]]]
}
|
 |
This post was edited 1 times, last on 08-12-2009, 22:11 by thommey
|
 |
Topic: [TCL] Ridiculously complicated regular expressions Forum: #tcl › code snippets Goto post |
thommey  | 01-12-2005, 23:15 | [TCL] Validate a date (format: dd.mm.yyyy) | Jabber |
(Administrator) Member since 03/2004 62 Posts
| Validate a date (format: dd.mm.yyyy)
1
2
3
4
|
proc isdate {str} {
if {![regexp {^(?:(?:[0-2]\d|30)\.(?:1\d|0[^2])|31\.(?:0[13578]|1[02])|([0-1]\d|2\d)\.02)\.(\d{4})$} $str "" t y] || ($t == 29 && ($y % 4 || ($y % 100 == 0 && $y % 400)))} { return 0 }
return 1
}
|
It checks if a date is _ 100%_ valid (30.02.xxxx will not be accepted, 29.02.1000 will be 0, 29.02.2004 will be 1)
Search for IP:port in a string as word
1
2
3
4
5
6
7
8
9
|
proc findgameserver {str} {
global re_gameserver;
set re_port {([1-9]\d{0,4}|(((([0-5]\d|6[0-4])\d|65[0-4])\d|655[0-2])\d|6553[0-5]))} # port 1-65535
set re_ipblk_m {([1-9]|(\d|1\d|2[0-4])\d|25[0-5])} # all but last ip block 0-255
set re_ipblk_e {((\d?|1\d|2[0-4])\d|25[0-4])} # last ip block 1-254
if {![info exists re_gameserver]} { # cache compiled re globally
set re_gameserver "\[\[:<:]]($re_ipblk_m\.){3}($re_ipblk_e):($re_port)\[\[:>:]]" }
regexp -- $re_gameserver $str
}
|
 |
This post was edited 3 times, last on 02-18-2010, 13:58 by thommey
|
 |
Topic: [EGG] Channel-Mode related things Forum: #tcl › code snippets Goto post |
thommey  | 08-09-2004, 15:28 | [EGG] Get the limit/key value of a channel | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
1
2
3
4
5
6
7
8
|
proc getchanlimit {chan} {
set chanmode [lindex [split [getchanmode $chan]] 0]
if {[string first l $chanmode] == -1} { return 0 }
if {[string first k $chanmode] == -1 || [string first k $chanmode] > [string first l $chanmode]} {
return [lindex [split $chanmode] 1]
}
return [lindex [split $chanmode] 2]
}
|
You have to modify it yourself to get they key (easy   |
This post was edited 3 times, last on 02-05-2014, 02:05 by thommey
|
 |
Topic: [EGG] Use variables inside strings and replacing them later Forum: #tcl › code snippets Goto post |
thommey  | 07-24-2004, 17:33 | [EGG] Use variables inside strings and replacing them later | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
|
set greetmsgs {
"Hi, how are you?"
"Hi $nick!"
"Hello $nick, welcome to $chan"
"]]] WELCOME to $chan!!!11111 ^^ ^^ [[["
"Hi [$nick], you have to pay 20$ to enter here"
}
bind join - * greet
proc greet {nick host hand chan} {
set greetmsg [lindex $::greetmsgs [rand [llength $::greetmsgs]]]
set greetmsg [subst -nocommands $greetmsg]
putserv "PRIVMSG $nick :$greetmsg"
}
|
 |
This post was edited 2 times, last on 08-12-2009, 22:08 by thommey
|
 |
Topic: [EGG] Check the lag of Bot<->Server Forum: #tcl › code snippets Goto post |
thommey  | 07-23-2004, 23:51 | [EGG] Check the lag of Bot<->Server | Jabber |
(Administrator) Member since 03/2004 62 Posts
|
01
02
03
04
05
06
07
08
09
10
11
|
bind pub - !lagcheck lagcheck
proc lagcheck {n u h c t} {
set ::laganswer([set ticks [clock clicks -milliseconds]]) $c
putserv "$ticks"
}
bind raw - 421 laganswer
proc laganswer {f k t} {
if {[info exists ::laganswer([set ticks [lindex [split $t] 1]])]} {
putserv "PRIVMSG $::laganswer($ticks) :Lag: [expr {[clock clicks -milliseconds] - $ticks}] ms"
}
}
|
 |
This post was edited 1 times, last on 08-12-2009, 22:06 by thommey
|
 |
Topic: [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth) Forum: #tcl › code snippets Goto post |
thommey  | 07-11-2004, 15:40 | Jabber |
(Administrator) Member since 03/2004 62 Posts
| 2. Asynchronous WHO nick n%na
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
|
bind raw - 354 who_info
bind raw - 315 end_of_who
bind pub - !auth who_pubcmd
proc who_pubcmd {nick host hand chan text} {
# Here we store where the answer for the WHO-request has to be send to
global whois_replyarray
if {$text == ""} {
putserv "PRIVMSG $chan :Please specify a nickname"
return 0
}
set text [lindex [split $text] 0]
set whois_replyarray([string tolower $text]) $chan
putserv "WHO $text n%na"
return 0
}
# ANSWER from server: End of /who - we got reply already?
proc end_of_who {from keyword text} {
global whois_replyarray
set targetnick [lindex [split $text] 1]
if {[info exists whois_replyarray([string tolower $targetnick])]} {
# Send that answer to where it belongs to
putserv "PRIVMSG $whois_replyarray([string tolower $targetnick]) :$targetnick is not on the network."
unset whois_replyarray([string tolower $targetnick])
}
}
proc who_info {from keyword text} {
if {[llength [set text [split $text]]] != 3} {
return 0
}
global whois_replyarray
set targetnick [lindex $text 1]
set auth [lindex $text 2]
if {[info exists whois_replyarray([string tolower $targetnick])]} {
if {$auth == "0"} {
putserv "PRIVMSG $whois_replyarray([string tolower $targetnick]) :$targetnick is not authed."
} else {
putserv "PRIVMSG $whois_replyarray([string tolower $targetnick]) :$targetnick is authed as \"$auth\""
}
unset whois_replyarray([string tolower $targetnick])
return 1
# return 1: Eggdrop will not parse it, so you can use a format you like
}
}
|
 |
This post was edited 3 times, last on 04-29-2009, 23:03 by thommey
The user has attached a file: who.tcl (Save, 1,507 Bytes, downloaded 174 times)
|
 |
Topic: [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth) Forum: #tcl › code snippets Goto post |
thommey  | 05-12-2004, 19:29 | [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth) | Jabber |
(Administrator) Member since 03/2004 62 Posts
| 1. Asynchronous WHOIS
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
bind raw - 330 whois_info_login
bind raw - 318 whois_endof
bind raw - 401 whois_notfound
bind pub - !auth whois_pubcmd
proc whois_pubcmd {nick host hand chan text} {
# Here we store where the answer for the WHOIS-request has to be send to
global whois_replyarray
if {$text == ""} {
putserv "PRIVMSG $chan :Please specify a nickname"
return 0
}
set whois_replyarray($text) $chan
# And send the WHOIS-request
putserv "WHOIS $text"
return 0
}
# ANSWER from server: No such nick
proc whois_notfound {from keyword text} {
global whois_replyarray
# Filter out the whois'ed nickname
set targetnick [lindex [split $text] 1]
if {[info exists whois_replyarray($targetnick)]} {
# Send that answer to where it belongs to
putserv "PRIVMSG $whois_replyarray($targetnick) :$targetnick is not on the network."
unset whois_replyarray($targetnick)
}
}
# We got the 330 Information -> User is authed as
proc whois_info_login {from key text} {
global whois_replyarray
set targetnick [lindex [split $text] 1]
if {[info exists whois_replyarray($targetnick)]} {
# Filter out the auth and send it to channel
putserv "PRIVMSG $whois_replyarray($targetnick) :$targetnick is authed as [lindex [split $text] 2]"
unset whois_replyarray($targetnick)
}
}
proc whois_endof {from keyword text} {
global whois_replyarray
set targetnick [lindex [split $text] 1]
if {[info exists whois_replyarray($targetnick)]} {
# END OF /WHOIS LIST. But no 330 received => User is not authed
putserv "PRIVMSG $whois_replyarray($targetnick) :$targetnick is not authed."
unset whois_replyarray($targetnick)
}
}
|
 |
This post was edited 2 times, last on 04-29-2009, 23:02 by thommey
The user has attached a file: whois.tcl (Save, 1,643 Bytes, downloaded 190 times)
|