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]
    }
}

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"
}

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
}

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]"}

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

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) "";
    }
}

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}}
}

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]

1

nagelfar.tcl -quiet -html -Welse0 -prefix l <file to test>

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
}

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
}

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
}

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
}

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)
}

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]' }

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)"
}

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

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
}

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
}

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."

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"
    }
}

1

set tok [http::geturl $url -query [http::formatQuery "allgemein\[titel]" $maske no_cache 1] -timeout 5000]

1

set tok [http::geturl $url -query [http::formatQuery "allgemein\[titel]" $maske no_cache 1 "tv\[sender]" A] -timeout 5000]

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]
}

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"

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"
}

1

proc multipliziere {a b} { return [expr $a * $b] }

1

if {$a * $b == 10} { puts "Ok" }

1

if {[string is integer $a]} { .. }

1

if [string is integer $a] { .. }

1

set a 4; set b 2; puts [expr $a*$b] ---> "8"

1

proc multipliziere {a b} { return [expr $a*$b] }

1

proc multipliziere {a b} { return [expr {$a * $b}] }

1

proc multiply {a b} { return [expr $a * $b] }

1

if {$a * $b == 10} { puts "Ok" }

1

if {[string is integer $a]} { .. }

1

if [string is integer $a] { .. }

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"!

1

proc multiply {a b} { return [expr $a*$b] }

1

proc multiply {a b} { return [expr {$a * $b}] }

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
}

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]"

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]
}

1
2
3

proc round {number {digits 0}} {
    return [expr {round(pow(10,$digits)*$number)/pow(10,$digits)}]
}

1

bind pub - $::botnick ..

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"
        }
    }
}