07-22-2018, 18:50 +0200
Search result (4)
All posts by: sKy\
AuthorPost
Topic: [TCL] Getting the source code of a web site   Forum: #tclcode snippets      Goto post
sKy\  02-06-2006, 13:55
(Moderator)

Avatar

Member since 05/2005
8 Posts
Location: Germany, Zeitz
# set website "www.yourhost.com"
# set content [web2data $website]
# returns:
# - if no error: the source of the website
# - if error: 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
proc web2data { website } {
    package require http
    # send the http request, -timeout sets up a timeout to occur after the specified number of milliseconds
    # we use catch to avoid an abort of the script in case of an error when executing http::geturl (e.g. due to an unsupported url)
    if { [catch { set token [http::geturl $website -timeout 3000]} error] } {
        putcmdlog "web2data: Error: $error"
        # if the the site does not exist
    } elseif { [http::ncode $token] == "404" } {
        putcmdlog "web2data: Error: [http::code $token]"
        # check if the request was successful, if yes -> put the html source code into $data
    } elseif { [http::status $token] == "ok" } {
        set data [http::data $token]
        # if a timeout has occurred, send "Timeout occured" to the standad output device
    } elseif { [http::status $token] == "timeout" } {
        putcmdlog "web2data: Timeout occurred"
        # send the error to the standard output device if there is one
    } elseif { [http::status $token] == "error" } {
        putcmdlog "web2data: Error: [http::error $token]"
    }
    # last but not least, release the memory which was used for these operations
    http::cleanup $token
    if { [info exists data] } {
        return $data
    } else {
        return 0
    }
}


# same like Mettwurst''s but as proc

[Not loaded: http://sky.tclhelp.net/sky.gif]
This post was edited 1 times, last on 08-14-2009, 03:23 by thommey
Topic: Random numbers (Better randomish numbers depending on the underlying kernel)   Forum: #tclcode snippets      Goto post
sKy\  12-13-2005, 17:50
(Moderator)

Avatar

Member since 05/2005
8 Posts
Location: Germany, Zeitz
                                                                                                                              
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
# generate random integer number in the range [0,max]
proc RandomInteger1 { max } {
    return [expr {int(rand()*$max) + 1}]
}

# generate random integer number in the range [0,max-1]
proc RandomInteger2 { max } {
    return [expr {int(rand()*$max)}]
}

# generate random integer number in the range [0,max]
proc RandomInteger3 { max } {
    return [expr {int(rand()*($max+1))}]
}

# generate random integer number in the range [min,max]
proc RandomInteger4 { min max } {
    return [expr {int(rand()*($max-$min+1)+$min)}]
}


[Not loaded: http://sky.tclhelp.net/sky.gif]
This post was edited 1 times, last on 08-14-2009, 03:21 by thommey
Topic: [TCL] get the calling proc   Forum: #tclcode snippets      Goto post
sKy\  10-12-2005, 02:10 | Re: Example
(Moderator)

Avatar

Member since 05/2005
8 Posts
Location: Germany, Zeitz
                                                                                                                              
1
2
3
4
5
# procname
proc procname { } {
    return [lindex [split [info level [expr [info level] - 1]]] 0]
}
# returns: the actual procname


                                                                                                                              
1
2
3
4
5
# preprocname
proc preprocname { } {
    return [lindex [split [info level [expr [info level] - 2]]] 0]
}
# returns: the name of the previous proc


                                                                                                                              
01
02
03
04
05
06
07
08
09
10
11
# evaltree
proc evaltree { } {
    set result [list]
    set level [info level]
    incr level -1
    for { set i 1 } { $i <= $level } { incr i 1 } {
        lappend result [lindex [info level $i] 0]
    }
    return $result
}
# returns: a list with all previous and the actual procname; the calling proc is this first element


[Not loaded: http://sky.tclhelp.net/sky.gif]
Topic: [EGG] Anti Flood Trigger   Forum: #tclcode snippets      Goto post
sKy\  10-12-2005, 01:46
(Moderator)

Avatar

Member since 05/2005
8 Posts
Location: Germany, Zeitz
                                                                                                                              
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
####################################################################################################################################
# preprocname
####################################################################################################################################

proc preprocname { } {
    return [lindex [split [info level [expr [info level] - 2]]] 0]
}

####################################################################################################################################
# variable:minus:one
####################################################################################################################################

proc variable:minus:one { varname } {
    if { [info exists $varname] } {
        set $varname [expr [set $varname] - 1]
        if { [set $varname] <= 0 } {
            unset $varname
        }
        return 1
    } else {
        return 0
    }
}

####################################################################################################################################
# utimer_floodprotection_action_intime (utimer method)
####################################################################################################################################
# advantage: no memory lag
# disadvantage: many utimers, high cpu usage
# usage: utimer_floodprotection_action_intime $allowed_actions $intime_seconds
# usage: if { [utimer_floodprotection_action_intime 3 10] } { return }
# usage: if { [utimer_floodprotection_action_intime 3 10 "$channel,$hostname"] } { return }

proc utimer_floodprotection_action_intime { allowed_actions intime_seconds {arglist ""} } {
    set preprocname "::utimer_floodprotection_action_intime_array("
    append preprocname [preprocname]
    if { $arglist != "" } {
        append preprocname ",$arglist)"
    } else {
        append preprocname ")"
    }
    if { ! [info exists $preprocname] } {
        set $preprocname 0
    }
    if { [set $preprocname] >= $allowed_actions } {
        return 1
    } else {
        incr $preprocname
        utimer $intime_seconds [list variable:minus:one $preprocname]
        return 0
    }
}

# testproc utimer method
proc teee { } {
    if { [utimer_floodprotection_action_intime 3 10] } {
        return "tee: floodprotected"
    } else {
        return "tee: okay"
    }
}

####################################################################################################################################
# flood_protection (unixtime method)
####################################################################################################################################
# advantage: no utimers, lower cpu usage
# disadvantage: memory lag, unixtime necessary
# usage: unixtime_flood_protection_action_intime $allowed_actions $intime_seconds
# usage: if { [unixtime_flood_protection_action_intime 3 10] } { return }
# usage: if { [unixtime_flood_protection_action_intime 3 10 "$channel,$hostname"] } { return }

proc unixtime_flood_protection_action_intime { allowed_actions intime_seconds {arglist ""} } {
    set preprocname "::unixtime_flood_protection__action_intime_array("
    set counter "::unixtime_flood_protection_counter_array("
    append preprocname [preprocname]
    append counter [preprocname]
    if { $arglist != "" } {
        append preprocname ",$arglist)"
        append counter ",$arglist)"
    } else {
        append preprocname ")"
        append counter ")"
    }
    if { ! [info exists $preprocname] } {
        set $preprocname [unixtime]
    }
    if { ! [info exists $counter] } {
        set $counter 1
    }
    set result [expr { [unixtime] - [set $preprocname] } ]
    if { $result < $intime_seconds } {
        if { $allowed_actions == 1 } {
            return 1
        }
        if { [set $counter] >= $allowed_actions } {
            return 1
        } else {
            incr $counter
            set $preprocname [unixtime]
            return 0
        }
    } else {
        unset -nocomplain $counter
        set $preprocname [unixtime]
        return 0
    }
}

# testproc unixtime method
proc feee { } {
    if { [unixtime_flood_protection_action_intime 3 10] } {
        return "feee: floodprotected"
    } else {
        return "feee: okay"
    }
}


[Not loaded: http://sky.tclhelp.net/sky.gif]
This post was edited 1 times, last on 08-12-2009, 21:26 by thommey
Go to forum
Unclassified NewsBoard 1.5.3-d | © 2003-4 by Yves Goergen | Time: 6118.6 msec, CPU time: 105.9 msec, 41 Database queries in 158.4 msec | 6.3 kB (49.3 kB) | Timezone: +0200