10-21-2017, 21:10 +0200
Search result (48)
All posts by: thommey
AuthorPost
Topic: [EGG] Debugger   Forum: #tclcode snippets      Goto post
thommey  09-04-2014, 02: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: eggdrophelp      Goto post
thommey  02-08-2014, 07: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: eggdrophelp      Goto post
thommey  05-15-2013, 19: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: workscript announcements      Goto post
thommey  05-19-2012, 00: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: workimminent problem solving      Goto post
thommey  11-03-2011, 17: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: #tclcode snippets      Goto post
thommey  10-29-2011, 23: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: #tclcode snippets      Goto post
thommey  01-21-2011, 22: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: #tclcode snippets      Goto post
thommey  09-07-2010, 01: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: #tclcode snippets      Goto post
thommey  09-01-2010, 15: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, 16:56 by thommey
Topic: [TCL] Hexdump   Forum: #tclcode snippets      Goto post
thommey  08-09-2010, 15: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: workscript announcements      Goto post
thommey  07-06-2010, 00: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, 00:22 by thommey
Topic: [TCL] work with CS Server   Forum: workimminent problem solving      Goto post
thommey  05-21-2010, 03:26 Jabber
(Administrator)
Member since 03/2004
62 Posts
I haven't used it myself (and I don't know anything about it, I hope it includes a readme file..) but I know what you're looking for:

Eggdrop rcon module, http://limit.org/rconmod.tar.gz (Mirror: http://thommey.tclhelp.net/mirror/rconmod.tar.gz ).
"Extends Eggdrop by adding rcon (remote console for game servers such as Half Life) commands."
Topic: [EGG] Redirect errors to a channel/query   Forum: #tclcode snippets      Goto post
thommey  12-20-2009, 12: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, 22:32 by thommey
Topic: [Site] Paste site   Forum: workscript announcements      Goto post
thommey  11-06-2009, 01: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: workscript announcements      Goto post
thommey  10-27-2009, 12: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 {\& \&amp; \< \&lt; \> \&gt; \" \&quot;} $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: workscript announcements      Goto post
thommey  10-26-2009, 23: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-26-2009, 23:34 by thommey
Topic: [EGG] Script to accept pastes via msg (w/coroutine example)   Forum: #tclcode snippets      Goto post
thommey  10-15-2009, 01: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 {\&nbsp;\&nbsp;\&nbsp;\&nbsp;} line
        puts $fs "$cnt[str {&nbsp;} [expr {4 - [string length $cnt]}]]&nbsp;$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 {\&nbsp;\&nbsp;\&nbsp;\&nbsp;} text
        puts $fs "$linenr[str {&nbsp;} [expr {4 - [string length $linenr]}]]&nbsp;$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: #tclcode snippets      Goto post
thommey  05-21-2009, 02: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, 17:44 by thommey
Topic: [EGG] Join/Part a channel and spy out (aka Bot-Request)   Forum: #tclcode snippets      Goto post
thommey  02-05-2009, 21: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-14-2009, 23:53 by thommey
Topic: [TCL] Trace open file handles (to get the filename from an open filesocket)   Forum: #tclcode snippets      Goto post
thommey  06-15-2008, 09: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, 02:14 by thommey
Topic: convert mirc script to tcl   Forum: workimminent problem solving      Goto post
thommey  06-03-2008, 17: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: #tclsmalltalk      Goto post
thommey  04-11-2008, 00: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: workscript announcements      Goto post
thommey  03-06-2008, 00: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: #tclcode snippets      Goto post
thommey  07-20-2007, 21: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, 02:22 by thommey
Topic: [TCL] Synchronized high resolution timestamp   Forum: #tclcode snippets      Goto post
thommey  02-27-2007, 22: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, 13:31 by thommey
Topic: help to convert (from mrc file to tcl)   Forum: eggdrophelp      Goto post
thommey  10-25-2006, 16: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: eggdrophelp      Goto post
thommey  10-24-2006, 15: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: workscript announcements      Goto post
thommey  10-15-2006, 17: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: #tclcode snippets      Goto post
thommey  10-03-2006, 17: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: #tclcode snippets      Goto post
thommey  09-25-2006, 22: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, 20:51 by thommey
Topic: [TCL] Socket examples (Simple Server and Client socket in plain TCL)   Forum: #tclcode snippets      Goto post
thommey  09-17-2006, 22: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, 20:49 by thommey
Topic: Why you should use braces {} around expressions.   Forum: #tclsmalltalk      Goto post
thommey  09-14-2006, 19: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, 11:33 by thommey
Topic: Why you should use braces {} around expressions.   Forum: #tclsmalltalk      Goto post
thommey  09-14-2006, 18: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, 11:48 by thommey
Topic: [EGG] strip control codes (bold/underline/color) & Generic message handler to deal with chanmode +c   Forum: #tclcode snippets      Goto post
thommey  09-05-2006, 20: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, 20:56 by thommey
Topic: [EGG] Make the bot establish a dcc-chat to me (like /ctcp <bot> chat)   Forum: #tclcode snippets      Goto post
thommey  08-27-2006, 19: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 11-30-2010, 23:38 by thommey
Topic: [EGG] Splitting long text into smaller parts for IRC output   Forum: #tclcode snippets      Goto post
thommey  03-05-2006, 13: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, 21:34 by thommey
Topic: [TCL] Round a number (5.55 => 5.6 instead of 5.5 as 'format %.2f' would do it)   Forum: #tclcode snippets      Goto post
thommey  03-04-2006, 21: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: #tclcode snippets      Goto post
thommey  05-26-2005, 20: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, 21:13 by thommey
Topic: [EGG] Join/Part a channel and spy out (aka Bot-Request)   Forum: #tclcode snippets      Goto post
thommey  05-26-2005, 18: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: #tclcode snippets      Goto post
thommey  05-24-2005, 21:49 Jabber
(Administrator)
Member since 03/2004
62 Posts
correct, I've corrected it
Topic: [EGG] Dns Lookups (with variable-passing)   Forum: #tclcode snippets      Goto post
thommey  05-24-2005, 21: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, 21:12 by thommey
Topic: [EGG] Random line from a file   Forum: #tclcode snippets      Goto post
thommey  03-31-2005, 11: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, 21:11 by thommey
Topic: [TCL] Ridiculously complicated regular expressions   Forum: #tclcode snippets      Goto post
thommey  01-12-2005, 22: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, 12:58 by thommey
Topic: [EGG] Channel-Mode related things   Forum: #tclcode snippets      Goto post
thommey  08-09-2004, 14: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, 01:05 by thommey
Topic: [EGG] Use variables inside strings and replacing them later   Forum: #tclcode snippets      Goto post
thommey  07-24-2004, 16: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, 21:08 by thommey
Topic: [EGG] Check the lag of Bot<->Server   Forum: #tclcode snippets      Goto post
thommey  07-23-2004, 22: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, 21:06 by thommey
Topic: [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth)   Forum: #tclcode snippets      Goto post
thommey  07-11-2004, 14: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, 22:03 by thommey
  The user has attached a file: who.tcl (Save, 1,507 Bytes, downloaded 96 times)
Topic: [EGG] Get the Q-Auth of a user (ircu AC token, X-Auth)   Forum: #tclcode snippets      Goto post
thommey  05-12-2004, 18: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, 22:02 by thommey
  The user has attached a file: whois.tcl (Save, 1,643 Bytes, downloaded 110 times)
Go to forum
Unclassified NewsBoard 1.5.3-d | © 2003-4 by Yves Goergen