tclhelp.net News

[TCL/TK] Simple font viewer

SIYB — Mon, 23 Aug 2010 21:32:23 +0100

Post:
http://geekosphere.org/1399/1399/

Screenshot:
http://geekosphere.org/wp-cont.../2010-08-23-231903_1680x...

Download:
http://siyb.mount.at/scripts/fontviewer0.2.tcl

File also attached to post. Please comment if you are satisfied.

Advanced Google

FordLawnmower — Sat, 29 May 2010 03:21:16 +0100

Loading:

Download the file AdvancedGoogle.tcl
Place the file in your eggdrop scripts directory
Add this line to eggdrop.conf -->> source scripts/AdvancedGoogle.tcl
Rehash or restart your eggdrop
(In the console) type .chanset #channelname +google "where #channelname is the channel you want the script on in"

Triggers:

!google search words (general searches)
!glocal search words (returns results related to a local area search)
!gvideo search words (returns video results)
!gnews search words (returns news results related you your search words)
!gbook search words (returns book results)
!gimage search words (returns image/picture results)
!gpatent search words (does a search of registered patents)

Example Output:
21:02:04 <Ford_Lawnmower> !google eggdrop
21:02:06 <QuadraZuadra> google Eggheads.org - Main Index http://www.eggheads.org/
21:02:07 <QuadraZuadra> google Eggheads.org - Downloads http://www.eggheads.org/downloads/
21:02:07 <QuadraZuadra> google slennox''s eggdrop page http://www.egghelp.org/

[EGG] Slot Script

Turbo — Tue, 27 Oct 2009 17:12:46 +0100

DELETED

Please attach a file to your postings :)

CyBex — Wed, 15 Apr 2009 22:27:36 +0100

no text

RSS lib

SIYB — Wed, 15 Apr 2009 21:09:24 +0100

A small script that will help writing applications that need to parse RSS(2.0) feeds. The most important (from my point of view) features of RSS2.0 have been included, please feel free to enhance the script and share your results if you feel that they are useful.

There is a small demo at the end of the script, it should cover the usage, don't forget to free the mallocs :>. Any questions? -> email / irc / thread

[code]

This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.

Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:

1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.

2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.

3. This notice may not be removed or altered from any source
distribution.

package require tdom

namespace eval feedRead {
    variable idPrefix "feedread";# the prefix to be used for feeds
    variable formats [list rss]
    variable tmpId;# stores the id temporarily (when a feed is added -> upvaring)
    variable feedId 0;# the id counter
    variable feedList [list];# list containing all feedids and the corresponding data
    namespace eval handle {}
}

#

Enduser relevant

Creates a feed

proc feedRead::create {xmlData id} {
    upvar 1 $id rid
    # create domtree for the feed
    set doc [dom parse -keepEmpties $xmlData]
    set rid [feedRead::addFeed $doc];# add feed to feedlist and return the id
}

return the feedlist of all feeds currently active

proc feedRead::getFeedList {} {
return $feedRead::feedList
}

clean up (destroy) all feeds

proc feedRead::destroyAll {} {
    foreach item [feedRead::feedList] {
      feedRead::destroy [lindex $item 0]
    }
}

#

deletes a feed from the list and gets rid of all traces

proc feedRead::destroy {id} {
    set doc [$id infoDoc];# get the document
    rename $id "";# delete the feed's procedure
    set search [feedRead::findFeed $id]
    set feedRead::feedList [lreplace $feedRead::feedList $search $search]
    $doc delete
}

checks if a format is known to the script

proc feedRead::checkFormat {format} {
return [lsearch $feedRead::formats $format]
}

joins prefix and id

proc feedRead::joinId {id} {
return [append foo $feedRead::idPrefix $id]
}

Returns a feedread feedid

proc feedRead::mkid {} {
    set id [feedRead::joinId $feedRead::feedId]
    incr feedRead::feedId
    return $id
}

find feed in list

proc feedRead::findFeed {id} {
return [lsearch -index 0 $feedRead::feedList $id]
}

replace feed in feedlist

proc feedRead::feedReplace {id replaceWith} {
set search [feedRead::findFeed $id]
set feedRead::feedList [lreplace $feedRead::feedList $search $search $replaceWith]
}

find and return feed from list

proc feedRead::returnFeed {id} {
return [lindex $feedRead::feedList [feedRead::findFeed $id]]
}

determine the feed type

proc feedRead::determineType {rootNode} {
return [$rootNode nodeName]
}

count the number of of a feed

proc feedRead::countItems {id} {
return [llength [lindex [feedRead::returnFeed $id] end]]
}

returns an by its place in the itemlist of the feed

proc feedRead::returnItemById {id iid} {
 if {[feedRead::countItems $id] < $iid} {
 error "Itemid '$iid' out of range"
 }
 return [lindex [lindex [feedRead::returnFeed $id] end] $iid]
}

adds a feed and the corresponding feed command

proc feedRead::addFeed {doc} {
    upvar #0 feedRead::tempId id
    set id [feedRead::mkid];# create a new id for this feed
    set root [$doc documentElement]
    set flist [list $id $doc $root [feedRead::determineType $root]]
    set feedRead::feedList [lappend feedRead::feedList $flist];# add feed to feedlist
    uplevel #0 {;# create the feed command
      proc $feedRead::tempId {option {iid -1}} {
      set id [string trim [dict get [info frame 0] proc] ::]
      set format [feedRead::getFeedType $id]

      if {[feedRead::checkFormat $format] != -1} {
      feedRead::handle::${format} $id $option $iid
      } else {
      error "'$format' not supported yet"
      }
      }
    }
    feedRead::feedReplace $id [lappend flist [feedRead::getChannelElement $id item -all]];# add all to the feedlist
    return $id
}

rss handler

proc feedRead::handle::rss {id option iid} {
    switch $option {
      "destroy" { return [feedRead::destroy $id] }
      "infoType" { return [feedRead::getFeedType $id] }
      "infoDoc" { return [feedRead::getFeedDoc $id] }
      "infoRoot" { return [feedRead::getFeedRoot $id] }
      "getChannelTitle" { return [feedRead::getChannelElement $id title] }
      "getChannelLink" { return [feedRead::getChannelElement $id link] }
      "getChannelDescription" { return [feedRead::getChannelElement $id description] }
      "getChannelLanguage" { return [feedRead::getChannelElement $id language] }
      "getChannelCopyright" { return [feedRead::getChannelElement $id copyright] }
      "getChannelManagingEditor" { return [feedRead::getChannelElement $id managingEditor] }
      "getChannelWebMaster" { return [feedRead::getChannelElement $id webMaster] }
      "getChannelPubDate" { return [feedRead::getChannelElement $id pubDate] }
      "getChannelLastBuildDate" { return [feedRead::getChannelElement $id lastBuildDate] }
      "getChannelCategory" { return [feedRead::getChannelElement $id category] }
      "getChannelGenerator" { return [feedRead::getChannelElement $id generator] }
      "getChannelDocs" { return [feedRead::getChannelElement $id docs] }
      "getChannelCloud" { return [feedRead::getChannelElement $id cloud] }
      "getChannelTtl" { return [feedRead::getChannelElement $id ttl] }
      "getChannelImage" { return [feedRead::getChannelElement $id image] }
      "getChannelRating" { return [feedRead::getChannelElement $id rating] }
      "getChannelTextInput" { return [feedRead::getChannelElement $id textInput] }
      "getChannelSkipHours" { return [feedRead::getChannelElement $id skipHours] }
      "getChannelSkipDays" { return [feedRead::getChannelElement $id skipDays] }
      "getChannelItems" { return [feedRead::getChannelElement $id item -all] }
      "getChannelItemLength" { return [feedRead::countItems $id] }
      "getItemTitle" { return [feedRead::getItemElement $id $iid title] }
      "getItemLink" { return [feedRead::getItemElement $id $iid link] }
      "getItemDescription" { return [feedRead::getItemElement $id $iid description] }
      "getItemAuthor" { return [feedRead::getItemElement $id $iid author] }
      "getItemCategory" { return [feedRead::getItemElement $id $iid category] }
      "getItemComments" { return [feedRead::getItemElement $id $iid comments] }
      "getItemEnclosure" { return [feedRead::getItemElement $id $iid enclosure] }
      "getItemGuid" { return [feedRead::getItemElement $id $iid guid] }
      "getItemPubDate" { return [feedRead::getItemElement $id $iid pubDate] }
      "getItemSource" { return [feedRead::getItemElement $id $iid source] }
      default { error "Unknown option ($option)" }
    }
}

#return the feed's type
proc feedRead::getFeedType {id} {
    return [lindex [split [feedRead::returnFeed $id]] 3]
}

return the feed's document

proc feedRead::getFeedDoc {id} {
return [lindex [split [feedRead::returnFeed $id]] 1]
}

return the feed root

proc feedRead::getFeedRoot {id} {
return [lindex [split [feedRead::returnFeed $id]] 2]
}

get channel

proc feedRead::getChannel {id} {
set root [feedRead::getFeedRoot $id]
return [$root getElementsByTagName channel]
}

get a channel element

proc feedRead::getChannelElement {id chanItem {option -single}} {
    set channel [feedRead::getChannel $id]
    set ci [$channel getElementsByTagName $chanItem]
    switch $option {
      "-single"    {
      foreach item $ci {;# loop all titles, if the parentNode of the title matches the channel, return it's text value
      if {[$item parentNode] == $channel} { return [$item asText] }
      }
      }
      "-all"    {
      return $ci
      }
      default { error "bad option \"$option\": must be -all or -single" }
    }
}

get an element

proc feedRead::getItemElement {id iid itemElement} {
    set item [[feedRead::returnItemById $id $iid] getElementsByTagName $itemElement]
    if {$item == ""} { return "" }
    if {[llength $item] > 1} {;# of there is more than one element by that name
      set rlist [list]
      foreach i $item {
      set rlist [lappend rlist [$i asText]]
      }
      return $rlist
    } else {
      return [$item asText]
    }
}

#

documentation demonstration

#
proc feedRead::demo {feed} {

    package require http

    set token [::http::geturl $feed -timeout 2000]
    set data [::http::data $token]
    ::http::cleanup $token

    # lets create the feed first, $data is the feed's data
    feedRead::create $data id
    puts "Feedlist: [feedRead::getFeedList]";# print feedlist

    # some information on the feed
    puts "\nfeed information:\n"
    puts " [$id infoType]";# the type of the doc
    puts " [$id infoDoc]";# the document identifier
    puts " [$id infoRoot]";# the root node identifier of the doc

    # channel related information -> [$id getChannelTitle] for instance
    set l {
      "getChannelTitle"
      "getChannelLink"
      "getChannelDescription"
      "getChannelLanguage"
      "getChannelCopyright"
      "getChannelManagingEditor"
      "getChannelWebMaster"
      "getChannelPubDate"
      "getChannelLastBuildDate"
      "getChannelCategory"
      "getChannelGenerator"
      "getChannelDocs"
      "getChannelCloud"
      "getChannelTtl"
      "getChannelImage"
      "getChannelRating"
      "getChannelTextInput"
      "getChannelSkipHours"
      "getChannelSkipDays"
      "getChannelItems"
      "getChannelItemLength"
    }
    puts "\nChannel related information:\n"
    foreach item $l {
      puts " $item: '[$id $item]'"
    }

    # item related stuff
    puts "\nitem related stuff:\n"
    set l {
      "getChannelItemLength"
      "getItemTitle"
      "getItemLink"
      "getItemDescription"
      "getItemAuthor"
      "getItemCategory"
      "getItemComments"
      "getItemGuid"
      "getItemPubDate"
      "getItemSource"
    }
    foreach item $l {
      puts " $item: '[$id $item 0]'"
    }

    # now that we are done we need to destroy all data related to the feed in order to prevent memory from going apeshit
    $id destroy
}

[/code]

eWebSource.tcl

HackeMate — Tue, 14 Apr 2009 10:41:32 +0100

Configure default options reading the header script, it will usefull for you.
You can download and source a file without access shell, any comment, bug, idea or suggestion is welcomed

[code]

eWebSource --
This script downloads and saves a url if it is a tcl file to be loaded

global eWS

Path where the files will be saved

set eWS(scriptdir) "scripts"

Should I add the downloaded file to config file to be loaded when rehash?
(1) Enable (0) Disable

set eWS(addsource) 1

Should I load the file after download? (Does not means rehash)

set eWS(load) 1

(1) Enable proxy (0) Disable

set eWS(dl.useproxy) 0

Timeout in milliseconds

set eWS(dl.timeout) "5000"

Proxy:port to connect trought firewall (will be random select)

set eWS(dl.proxy) {
    216.194.70.3:8118
    200.209.145.179:3128
    83.17.123.186:8080
    212.93.193.83:8082
    203.162.224.137:80
    203.162.224.139:80
    217.17.248.171:80
}

Default proxy port if not defined. Do not force script to use this, most of
times will not work.

set eWS(dl.defaultport) "8080"

set eWS(me.name) "eWebSource"
set eWS(me.version) "1.0"
set eWS(me.fileName) [file tail [info script]]
set eWS(me.author) "HackeMate"
set eWS(me.contact) "HackeMate <Sentencia@eggdrop.es>"
package require http

setudef flag websource

bind pub n !websource eWebSource

proc eWebSource {nick uhost hand chan text} {

 if {![channel get $chan websource]} {
 putserv "NOTICE $nick :This channel has this script disabled; enable it using .chanset $chan +websource via party line"
 return
 }
 set url [lindex [split $text] 0]
 set source [lindex [split $text] 1]
 set load [lindex [split $text] 2]

 # You can use this command directly via tcldebug or .tcl command party line
 # if you know already what are the right arguments
 eWSdownload $url $chan $source $load

}
proc eWSIsIp {arg} {
 # modify these if you want to check specifi ranges for
 # each portion - now it look for 0 - 255 in each
 set ipnum1 {\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5]}
 set ipnum2 {\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5]}
 set ipnum3 {\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5]}
 set ipnum4 {\d|[1-9]\d|1\d\d|2[0-4]\d|25[0-5]}
 set fullExp {^($ipnum1)\.($ipnum2)\.($ipnum3)\.($ipnum4)$}
 set partialExp {^(($ipnum1)(\.(($ipnum2)(\.(($ipnum3)(\.(($ipnum4)?)?)?)?)?)?)?)?$}
 set fullExp [subst -nocommands -nobackslashes $fullExp]
 set partialExp [subst -nocommands -nobackslashes $partialExp]
 if [string equal int focusout] {
 if [regexp -- $fullExp $arg] {
 return 1
 } else {
 return 0
 }
 } else {
 return [regexp -- $partialExp $arg]
 }
}

proc eWSLog {target string} {
 global eWS
 if {![validchan $target]} {
 putlog "$eWS(me.name)\: $string"
 } else {
 putserv "PRIVMSG $target :$eWS(me.name)\: $string"
 }
}

proc eWSdownload {webtarget {chan "log"} {addSource ""} {rehash ""}} {
 global eWS config
 regsub -all -- {17|02|37|26|03(\d{1,2})?(,\d{1,2})?} $webtarget "" target
 set isName [lindex [split $target "|"] 0]
 if {[file extension $isName] eq ".tcl"} {
 set fileName $isName
 set target [join [lrange [split $target "|"] 1 end] "|"]
 } else {
 set fileName [file tail $target]
 }
 if {![regexp -nocase {^(http://)?([^/:]+)([0-9]+))?(/.*)?$} $target]} {
 if {$webtarget eq ""} {
 set target "Put some url link. Usage: !websource 'url link0' 'add to config file (yes or no)' 'load when download (yes or no)'"
 }
 eWSLog $chan "Unsupported URL: $target"
 return
 }
 if {([file extension $target] ne ".tcl") && ([file extension $fileName] ne ".tcl")} {
 eWSLog $chan "That url does not seems a valid tcl file, if you are sure that really it is, Especific the name using: !websource name.tcl\|$target (I will stop now)"
 return
 }
 if {$addSource eq ""} {
 set addSource $eWS(addsource)
 }
 if {$rehash eq ""} {
 set rehash $eWS(load)
 }
 if {$addSource eq "yes"} {
 set addSource 1
 }
 if {$addSource eq "no"} {
 set addSource 0
 }
 if {($addSource != 1) && ($addSource != 0)} {
 eWSLog $chan "Should I add file to source or not? Use !websource $webtarget 'yes (1) or no (0)' $rehash"
 return
 }
 if {$rehash eq "yes"} {
 set rehash 1
 }
 if {$rehash eq "no"} {
 set rehash 0
 }
 if {($rehash != 1) && ($rehash != 0)} {
 eWSLog $chan "Should I add load the file after download or not? Use !websource $webtarget $addSource 'yes (1) or no (0)'"
 return
 }
 if {$eWS(dl.useproxy)} {
 set randProxy [lindex $eWS(dl.proxy) [rand [llength $eWS(dl.proxy)]]]
 set port [lindex [split $randProxy ":"] 1]
 set proxy [lindex [split $randProxy ":"] 0]
 if {![eWSIsIp $proxy]} {
 eWSLog $chan "$proxy Is Not a valid ip proxy. I will go ahead anyway (sorry)"
 set proxy {}
 set port {}
 }
 if {![string is digit -strict $port]} {
 if {![string is digit -strict $eWS(dl.defaultport)]} {
 set eWS(dl.defaultport) "8080"
 eWSLog $chan "$port and the default $eWS(dl.defaultport) Are Not valid port numbers. I will use the most common proxy port number: 8080 (recheck your config, probably I will break)"
 set port "8080"
 } else {
 eWSLog $chan "$port Is Not a valid port number. I will use the default one: $eWS(dl.defaultport) - It may not work (verify your config)"
 }
 }
 if {$proxy ne ""} {
 eWSLog $chan "Proxy: $proxy\:$port"
 }
 } else {
 set proxy {}
 set port {}
 }
 set fileTcl [file join $eWS(scriptdir) $fileName]
 if {[file exists $fileTcl]} {
 eWSLog $chan "$fileName already exists. Last modified [duration [expr [clock seconds]-[file mtime $fileTcl]]] ago"
 # Use 02!websource $target yes02 to overwrite. ?
 return
 }
 http::config -useragent "$eWS(me.name) - $eWS(me.version)" -proxyhost $proxy -proxyport $port
 if {![string is digit -strict $eWS(dl.timeout)]} {
 set eWS(dl.timeout) "5000"
 }
 set token [http::geturl $target -binary 1 -timeout $eWS(dl.timeout)]
 upvar #0 $token state
 regexp {[0-9]{3}} $state(http) ncode
 if {$ncode eq ""} {
 set ncode $state(http)
 }
 switch -- $ncode {
 "200" {
 eWSLog $chan "File reached $state(currentsize) bytes. MD5sum: [md5 $state(body)]"
 if {$addSource} {
 set fs [open $fileTcl w]
 puts -nonewline $fs $state(body)
 close $fs
 eWSLog $chan "$fileTcl Saved."
 set fs [open $config r]
 set data [split [read $fs] \n]
 close $fs
 lappend data "\# File saved from $target and loaded automaticly by $eWS(me.name) $eWS(me.version)"
 lappend data "source $fileTcl"
 set fs [open $config w]
 puts $fs [join $data \n]
 close $fs
 eWSLog $chan "This file was added to config file."
 }
 if {$rehash} {
 if {[catch {source $fileTcl} msg]} {
 eWSLog $chan "There is an error loading $fileTcl\:\n $msg"
 } else {
 eWSLog $chan "File loaded sucessfully."
 }
 }
 }
 "404" {
 eWSLog $chan "No such file or webpage."
 http::cleanup $token
 return
 }
 "default" {
 eWSLog $chan "unforeseen circumstance. Server responded: $state(http)"
 }
 }
 http::cleanup $token
}

eWSLog "log" "$eWS(me.fileName) $eWS(me.version) loaded - by $eWS(me.author)"
[/code]

YouTube info

HackeMate — Sun, 12 Apr 2009 10:37:44 +0100

It was updated, now handles 302 redirects

Reading the header' script you can configure what it should send to channel. So you can put it in your native language too
To enable it: .chanset #channel +ourtube

[code]#

ourTube.tcl --
This file search the web target and show relevant information about.
Is posible define a YouTube account and the bot will log in. Useful
when the link are for adult people i.e. It will show the first link
that finds in a whole phrase.

HackeMate (Sentencia) Sentencia@eggdrop.es

This program is free software; you can redistribute it and/or
modify it _only for your own use_

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

Please, use the email to contact with the author for let him know about all
what you could do. Everyone wants develop his software as well.

Thank you for feed my empiric life.

If you like, you can contact with the author to suggest him features. By the
way, do not ask him to make Login, he is working on that.

This is what you need to get this script work:
Type in partyline: .chanset #channel +ourtube

Changelog:
Fixes:
Resolved Tcl error [otPub]: can't read "views": no such variable
Resolved eternal ignore-protection issue

Added features:
Now will forward to new location 302 http code received when pasting
http://youtube. links
Explicit message when 404 error (not found)
All non 200, 302, 303, 404 errors will stop the procedure showing proper reason

setudef flag ourtube
global ourtube tcl_platform

(1) Enable or (0) disable colors

set ourtube(colors) 1

Flood Protection: after show a link, will ignore all links few seconds
This means 1 link per 10 seconds.

set ourtube(rest) 10

What language you can receive the youTube data? (if works heh)

set ourtube(lang) en

This is the final output message what you will read in your channel.
You can configure all fields that your eggdrop will show.
will return the title of the video </li> <li><author> It was the author himself who had uploaded the video </li> <li><views> How many views the video has </li> <li><rating> His rating </li> <li><description> Information by author - This may be disabled because it can </li> <li> contain spam </li> <li><comment> Will show the last comment if exists - Same as description, take care </li> <li> with spam. </li> </ol> set ourtube(output) "02<title>02. (by <author>) <views> views, <rating> rating. Last comment: <comment>" <ol> <li>This is not required to edit, or yes. </li> </ol> set ourtube(author) "HackeMate" set ourtube(contact) "HackeMate <<a href="mailto:Sentencia@eggdrop.es">Sentencia@eggdrop.es</a>>" set ourtube(fileName) [file tail [info script]] set ourtube(projectName) "ourTube" set ourtube(version) "1.0.1" set ourtube(package.http) [package require http] set ourtube(protection) "" if {$tcl_platform(os) eq "Linux"} { set platfrm "X11" } else { set platfrm $tcl_platform(os) } http::config -useragent "Mozilla/5.0 ($platfrm; U; $tcl_platform(os) $tcl_platform(machine); $ourtube(lang); rv:1.9.0.3) ourTube 1.0" -accept "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8" bind pubm - * otPub proc otPub {nick uhost hand chan text} { if {![channel get $chan ourtube]} { return } global ourtube regsub -all -- {17|02|37|26|03(\d{1,2})?(,\d{1,2})?} $text "" arg set webTarget [lsearch -inline [split $arg] {*http://*youtube*/watch?*}] if {([info exists ourtube(protection)]) && ([string is digit -strict $ourtube(protection)])} { set rest [expr [clock seconds]-$ourtube(protection)] if {$rest >= $ourtube(rest)} { set ourtube(protection) "" } } else { set ourtube(protection) "" } if {$webTarget ne ""} { if {! [regexp -nocase {^(http://)?([^/:]+)([0-9]+))?(/.*)?$} $webTarget]} { otLog "Unsupported URL: $webTarget" return } if {$ourtube(protection) ne ""} { otLog "Resting... (flood protection) [duration [expr ([clock seconds]-$ourtube(protection))]] left" return } set ourtube(protection) [clock seconds] otLog "Getting $webTarget ... from $nick on $chan" set data [otGet $webTarget] if {!$ourtube(colors)} { regsub -all -- {17|02|37|26|03(\d{1,2})?(,\d{1,2})?} $data "" data } if {[string length $data] == 0} { set data "I was not able to reach Youtube's link. Probably I get a timeout. Try again." } otLog "$data" putserv "PRIVMSG $chan :$data" utimer $ourtube(rest) [list set ourtube(protection) ""] } } proc otGet {web {relocation ""}} { global ourtube set token [http::geturl $web -timeout 4000] upvar #0 $token state set lastcode $state(http) regexp {[0-9]{3}} $lastcode ncode if {$ncode eq ""} { set ncode $lastcode } switch -- $ncode { "200" { } "302" { foreach {flag value} $state(meta) { if {$flag eq "Location"} { # Due to invalid youtube link but valid url syntax we can # receive an url forward. this handles that http::cleanup $token otLog "$web forwards us to $value" return [otGet $value "(Relocated)"] } } } "303" { otLog "This video does not exists." http::cleanup $token return "That video does not exists. Server responded: $lastcode" } "404" { otLog "$web - No such webpage." http::cleanup $token return "$web - No such webpage" } default { http::cleanup $token otLog "unforeseen circumstances. Server responded: $lastcode" return "unforeseen circumstances. Server responded: $lastcode" } } set data [string map {""\;" "\"" "&\;quot\;" "\"" "&" "&"} $state(body)] http::cleanup $token set author "" set description "" set views "" set rating "" regexp {<title>(.*?)} $data "" title
 regexp {class="hLink fn n contributor">(.*?)
} $data "" author
 regexp {.*} $data "" description
 regexp {(.*?)} $data "" views
 regexp {
(.*?).*} $data "" rating
 # This is not so smart way. I know, sorry about
 set comments ""
 set description ""
 regexp {
(.*?)
 if {$comments ne ""} {
 regexp { rel="nofollow">(.*?)} $comments "" user
 regexp {(.*?)} $comments "" timeago
 regexp {
(.*?)
} $comments "" comment
 set comment [string map {\n " " "
" ""} $comment]
 regsub -all -- {\<[^\>]*\>|\t} $comment "" comment
 regsub -all {\s+} $comment " " comment
 set comment "\<$user [string trim $timeago]\> [string trim $comment]"
 } else {
 set comment ""
 }
 regsub -all -- {\<[^\>]*\>|\t} $title "" title
 regsub -all -- {\<[^\>]*\>|\t} $description "" description
 regsub -all -- {\<[^\>]*\>|\t} $views "" views
 regsub -all -- {\<[^\>]*\>|\t} $rating "" rating
 set rating [lindex [split $rating] 0]
 set title "$relocation $title"
 set title [string trim $title]
 if {![string is digit -strict $views]} {
 set views "no"
 }
 if {![string is digit -strict $rating]} {
 set rating "no"
 }
 if {$comment eq ""} {
 set comment "This video doesn't have any comments until now"
 }
 if {$description eq ""} {
 set description "This video doesn't have any description"
 }
 set output [string map [list "" $title "<author>" $author "<description>" $description "<views>" $views "<rating>" $rating "<comment>" $comment] $ourtube(output)] return $output } <ol> <li>upvar #0 $token state </li> </ol> proc otLog {arg} { global ourtube putlog "$ourtube(projectName): $arg" } otLog "$ourtube(fileName) $ourtube(version) Loaded - by $ourtube(author)" [/code] </article> <article> <h1>Example to connect Msn</h1> HackeMate — Fri, 09 May 2008 10:55:31 +0100 This is not a final script to use msn, it just contain the basic part for log in, the else of work only requires read the msn commands. The comments are based in <a href="http://www.hypothetic.org/docs/msn/">http://www.hypothetic.org/docs/msn/</a>, my English is not so good [code] #!/usr/bin/tclsh <ol> <li> </li> <li>This is an elemental Msn client using the protocol MSNP8 (windows messenger default) </li> <li>Not third-party client. It's an example for your information. </li> <li>Written by HackeMate @ QuakeNet </li> <li> Sentencia @ IRC-Hispano </li> <li><a href="mailto:Sentencia@librepensamiento.es">Sentencia@librepensamiento.es</a> </li> </ol> proc msn:sdata {sock str} { puts $sock "$str" msn:echo "*** $sock: $str" } proc msn:echo {str} { switch -- [string range $str 0 3] { "::: " { set prefix "Msn:>" set str [string range $str 4 end] } "*** " { set prefix "02Sending:\>02" set str [string range $str 4 end] } "!!! " { set prefix "2Incomming ERROR:02" set str [string rane $str 4 end] } "default" { set prefix "Incomming data:" } } puts stdout "$prefix $str" } proc msn:nexus {} { # Passport authentication begins with the passport nexus, just as logging into messenger begins with the Dispatch Server # Using secure http request to the next path. package require http package require tls http::register https 443 ::tls::socket set token [http::geturl <a href="https://nexus.passport.com/rdr/pprdr.asp">https://nexus.passport.com/rdr/pprdr.asp</a>] upvar #0 $token state foreach {name value} $state(meta) { if {$name == "PassportURLs"} { set data [split $value ","] set dalogin [lsearch -all -inline $data "DALogin=*"] set dalogin [lindex [split $dalogin "="] 1] msn:echo "::: PassPort saved. We are jumping to $dalogin" msn:passport $dalogin return } } # I admit that this is a dirty way to know when passort auth was failed. # Sorry about, I'm lazy. msn:echo "!!! Authentication process was not good." close $::msn(sock) # This exist command will exit from the previous command executed in msn:Login vwait forever exit return } proc msn:passport {url} { # The client sends a https get request for the url given to it by the nexus (saved in $dalogin, here $url) # The login is waiting the last parameters that we saved in $::msn(auth), like a header. package require http package require tls http::register https 443 ::tls::socket set url "https://$url" set account [string map [list "\@" "\%40"] $::msn(account)] set token [http::geturl $url -headers [list Authorization "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=$account,pwd=$::msn(password),$::msn(auth)"]] upvar #0 $token state # If we fail the authentication, instead HTTP 200 it will return something like HTTP 302, or if # the syntax was badly, HTTP 401. If all is Ok, this foreach will connect us. foreach {name value} $state(meta) { if {$name == "Authentication-Info"} { regexp {\'(.*?)\'} $value "" cookie incr ::msn(trid) msn:sdata $::msn(sock) "USR $::msn(trid) TWN S $cookie" } } } <ol> <li>Configuration </li> </ol> set ::msn(account) "Your@Messenger.account" set ::msn(password) "AGoodPassword" <ol> <li>We define here the version protocol. </li> <li>This variable will be used only twice. </li> </ol> set ::msn(version) "MSNP8 CVR0" <ol> <li>(CVR) The CVR command sends version information about a client and operating </li> <li>system to the server. For the official client, the server will reply with </li> <li>information about a recommended version of the client. It's debatable whether </li> <li>third-party clients should send CVR. Microsoft might start blocking users based on </li> <li>this command, or they might tread third-party clients better than now if there was </li> <li>evidence that a significant number of people used them. Any way, Microsoft </li> <li>has no way to verify the information given. </li> </ol> <ol> <li>Independently of all this debat, Where are you from? Spanish location is 0x0C0A </li> <li>American users send: 0x0409 </li> <li>For your information: <a href="http://www.microsoft.com/globaldev/reference/oslocversion.mspx">http://www.microsoft.com/globaldev/reference/oslocversion.mspx</a> </li> <li>This var may define your Locale configuration </li> </ol> set ::msn(location) "0x0C0A" <ol> <li>This is our info. It is what a Windows XP & windows messenger sends. </li> </ol> set ::msn(msnms) "winnt 5.1 i386 MSMSGS 4.7.3001 WindowsMessenger" <ol> <li>End of parameters. </li> </ol> <ol> <li>We are going </li> </ol> proc msn:Login { { server "messenger.hotmail.com" } {port 1863} } { # (TrID) The Transaction IDs, abbreviated as TriDs, are used to much a client command with a server # response. Commands sent by the client are required to contain a TrID, and commands from the server # sent in direct response to that command will contain the same TrID (with some exception). # Every TrID is a number between 0 and 4294967295. Using this TrID wrongly may cause confusion and # server and client will be unstable. if {![info exists ::msn(trid)]} { set ::msn(trid) 1 } # Easy to make multi-server, almost all depend of this (and previous) var name. set ::msn(sock) [socket $server $port] msn:echo "::: Trying to connect $server:$port- sockname: $::msn(sock)" # Because we can receive data in any moment, we need read it as fast as we can, that's why I used # -buffering line instead full. In certain moment negotiating the connection, the socket can get # stuned or we are forced to execute manually gets, if you don't use vwait forever command. # I had bad experiencies with this command in x-chat. fconfigure $::msn(sock) -buffering line -blocking no fileevent $::msn(sock) readable [list msn:gdata $::msn(sock)] msn:sdata $::msn(sock) "VER $::msn(trid) $::msn(version)" vwait forever } proc msn:gdata {socket} { if {[eof $socket]} { msn:echo "::: Closed connection." close $socket exit return } set datos [gets $socket] foreach data [split $datos \n] { msn:echo "$data" if {$data == "VER $::msn(trid) $::msn(version)"} { incr ::msn(trid) msn:sdata $::msn(sock) "CVR $::msn(trid) $::msn(location) $::msn(msnms) $::msn(account)" } set cvr [join [lrange [split $data] 0 1]] if {$cvr == "CVR $::msn(trid)"} { incr ::msn(trid) msn:sdata $::msn(sock) "USR $::msn(trid) TWN I $::msn(account)" } set usr [join [lrange [split $data] 0 3]] if {$usr == "USR $::msn(trid) TWN S"} { # Rude way to save this parameters... # Thanks thommey for advice to use a foreach loop # It will work, I will change it soon set udata [split $data ","] set lc [lsearch -all -inline $udata "lc=*"] set lc [lindex [split $lc "="] 1] set id [lsearch -all -inline $udata "id=*"] set id [lindex [split $id "="] 1] set tw [lsearch -all -inline $udata "tw=*"] set tw [lindex [split $tw "="] 1] set ru [lsearch -all -inline $udata "ru=*"] set ru [lindex [split $ru "="] 1] set ct [lindex [lsearch -all -inline $udata "*ct=*"] 0] set ct [lindex [split $ct] 4] set ct [lindex [split $ct "="] 1] set kpp [lsearch -all -inline $udata "kpp=*"] set kpp [lindex [split $kpp "="] 1] set kv [lsearch -all -inline $udata "kv=*"] set kv [lindex [split $kv "="] 1] set ver [lsearch -all -inline $udata "ver=*"] set ver [lindex [split $ver "="] 1] set rn [lsearch -all -inline $udata "rn=*"] set rn [lindex [split $rn "="] 1] set tpf [lsearch -all -inline $udata "tpf=*"] set tpf [lindex [split $tpf "="] 1] set ::msn(auth) "lc=$lc,id=$id,tw=$tw,ru=$ru,ct=$ct,kpp=$kpp,kv=$kv,ver=$ver,rn=$rn,tpf=$tpf" msn:nexus } if {$data == "USR $::msn(trid) OK $::msn(account) $::msn(account) 1 0"} { msn:echo "::: Now we are logged in." # This command will mark us as connected for else people. msn:sdata $::msn(sock) "SYN 8 0" } # SYN command will return our buddy list if {[join [lrange [split $data] 0 1]] == "SYN 8"} { msn:sdata $::msn(sock) "CHG 9 NLN 0" } if {[lindex [split $data] 0] == "ClientIP:"} { set ::msn(selfip) [lindex [split $data] 1] } if {[lindex [split $data] 1] == "ClientPort:"} { set ::msn(selfport) [lindex [split $data] 1] msn:echo "Our IP is: $::msn(selfip) and the port: $::msn(selfport)" msn:sdata "SYN 8 0" } if {[lindex [split $data] 0] == "XFR"} { close $::msn(sock) set server [lindex [split $data] 3] set port [lindex [split $server ":"] 1] set server [lindex [split $server ":"] 0] incr ::msn(trid) msn:Login $server $port } # Catching errors (this is just a few list of) set cmd [lindex [split $data] 0] set cparm [lindex [split $data] 1] switch -- $cmd { "710" { msn:echo "!!! Bad CVR parameters sent." } "711" { msn:echo "!!! Write is blocking." } "712" { msn:echo "!!! Session is overloaded." } "713" { msn:echo "!!! Calling too rapidly. This occurs when the client repeatedly calls someone who is offline or blocking them" msn:echo "!!! in response to the commands that the server rejects. This is a way to know who is blocking you." } "714" { msn:echo "!!! Too many sessions." } "715" { if {$cparm == "30"} { msn:echo "!!! PRP setting an invalid phone type of three or less characters." } if {$cparm == "31"} { msn:echo "!!! ERROR- Changing display name (REA) on an unverified Passport account." } } "731" { msn:echo "!!! ERROR- Not expected. Bad formatted CVR." close $::msn(sock) return } } } } puts stdout "Msn Client loaded" [/code] </article> <article> <h1>[EGG] request</h1> Turbo — Sun, 17 Jun 2007 22:02:39 +0100 <ol> <li> Author: Björn 'Turbo' B. </li> <li> </li> <li>Copyright © 2009 Turbo-Dev.org - All Rights Reserved. </li> </ol> # <ol> <li>Version/Date check list. </li> </ol> # 1.0 - June 18 2007 # 1.1 - December 22 2009 # 1.2 - Januari 21 2010 namespace eval ::request_system { # - Config ## Set here the trigger you wanna use. variable reqtrigger "." ## Please leave this. variable reqversion "1.2" ## Set here the channel (where users can use the request command). variable reqchannel "#choose-your-channel" ## Set here the channel where all msgs report goes to. variable reportchannel "#choose-your-channel" ## Set here the require users that a requested channel needs. variable require "25" # - File Check if {![file exists request]} { file mkdir request } # - Binds bind pub -|- ${reqtrigger}request [namespace current]::start bind pub m|m ${reqtrigger}suspend [namespace current]::suspend bind pub m|m ${reqtrigger}unsuspend [namespace current]::unsuspend bind pub m|m ${reqtrigger}info [namespace current]::suspended bind pub m|m ${reqtrigger}remove [namespace current]::removebot bind need -|- * [namespace current]::need:check # - End Of Bindings # - End Of Config ## Don`t touch anything below this (only if you know what you are doing) proc start {nick host hand chan text} { global request variable reqchannel variable reportchannel variable require set requestchannel [lindex [split $text] 0] if {$reqchannel == "" || $reportchannel == "" || $require == ""} { putlog "(Request) Please check your Configuration." return 0 } elseif {![string equal -nocase $chan "$reqchannel"]} { putserv "PRIVMSG $chan :(Request) You can only request on channel: $reqchannel" return 0 } elseif {[info exists request(proceeding)]} { putserv "PRIVMSG $chan :(Request) There is already a request proceeding, please wait and try again." return 0 } elseif {$requestchannel == ""} { putserv "PRIVMSG $chan :(Request) $::lastbind <#channel>" return 0 } elseif {[string index $requestchannel 0] != "#"} { putserv "PRIVMSG $chan :(Request) ($requestchannel) is no such channel name." return 0 } elseif {[string tolower $requestchannel] == "[string tolower $reqchannel]"} { putserv "PRIVMSG $chan :(Request) ($requestchannel) is no request channel." return 0 } elseif {[issuspended $requestchannel] == "1"} { putserv "PRIVMSG $chan :(Request) ($requestchannel) has been suspended." return 0 } elseif {[validchan $requestchannel] == "1"} { putserv "PRIVMSG $chan :(Request) Already on channel: ($requestchannel)" return 0 } else { putquick "PRIVMSG $reportchannel :(Request) Status: Proceeding - Channel: $requestchannel - Nickname: $nick" channel add $requestchannel set request(proceeding) "1" set request(chan) "$requestchannel" set request(nick) "$nick" set request(required) "$require" } bind raw - 315 [namespace current]::end proc end {from key text} { global request variable reportchannel if {![info exists request(proceeding)]} { return } set users "[llength [chanlist $request(chan)]]" if {$users < "$request(required)"} { channel remove $request(chan) set request(reason) "Not enough users." putquick "privmsg $request(nick) :(Request) Failed: Not enough users on $request(chan) you need $request(required) users, and currently have $users" putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) } elseif {![onchan $request(nick) $request(chan)]} { channel remove $request(chan) set request(reason) "User not channel." putquick "privmsg $request(nick) :(Request) Failed: Didn`t found you on $request(chan)" putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) } elseif {![isop $request(nick) $request(chan)]} { channel remove $request(chan) set request(reason) "User not opped on channel." putquick "privmsg $request(nick) :(Request) Failed: You don`t have op on $request(chan)" putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) } elseif {![onchan Q $request(chan)]} { channel remove $request(chan) set request(reason) "Q not on channel" putquick "privmsg $request(nick) :(Request) Failed: Didn`t found Q on $request(chan)" putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) } else { putquick "PRIVMSG $request(nick) :(Request) $request(nick) Your request is accepted, to remove me from $request(chan) you can ask bot owner: $::owner" putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: Yes" channel remove $request(chan) } unset request(chan) unset request(nick) unset request(required) unset request(proceeding) unbind raw - 315 [namespace current]::end } } proc issuspended {chan} { if {![file exists request/suspended.txt]} { return 0 } set file [open request/suspended.txt "r+"] set found 0 while {![eof $file]} { set info [gets $file] if {[string equal -nocase "[lindex [split $info] 0]" $chan]} { set found "1" } } close $file if {$found == "1"} { return 1 } else { return 0 } } proc removebot {nick host hand chan text} { variable reqchannel variable reportchannel set removechannel [lindex [split $text] 0] if {[string equal -nocase $removechannel "$reqchannel"]} { putserv "PRIVMSG $chan :(Request) ($removechannel) not allowed." return 0 } elseif {$removechannel == ""} { putserv "PRIVMSG $chan :(Request) $::lastbind <#channel>" return 0 } elseif {[validchan $removechannel] == "0"} { putserv "PRIVMSG $chan :(Request) ($removechannel) is not a valid channel." return 0 } else { channel remove $removechannel putquick "PRIVMSG $reportchannel :(Request) Removed channel: $removechannel." } } proc need:check {chan type} { global request variable reportchannel if {![info exists request(proceeding)]} { return } if {![string equal -nocase $chan "$request(chan)"]} { return } switch -exact -- [string tolower [lindex [split $type] 0]] { "unban" { channel remove $request(chan) set request(reason) "Couldn`t check the channel because i found myself banned." putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) unset request(chan) unset request(nick) unset request(required) unset request(proceeding) } "invite" { channel remove $request(chan) set request(reason) "Couldn`t check the channel because the channel is set to +i (invite only)." putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) unset request(chan) unset request(nick) unset request(required) unset request(proceeding) } "limit" { channel remove $request(chan) set request(reason) "Couldn`t check the channel because the channel is set to +l (limit)." putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) unset request(chan) unset request(nick) unset request(required) unset request(proceeding) } "key" { channel remove $request(chan) set request(reason) "Couldn`t check the channel because the channel is set to +k (key)." putquick "PRIVMSG $reportchannel :(Request) Channel: $request(chan) - Nickname: $request(nick) - Accepted: No - Reason: $request(reason)" unset request(reason) unset request(chan) unset request(nick) unset request(required) unset request(proceeding) } } unbind raw - 315 [namespace current]::end } proc suspend {nick host hand chan text} { if {![file exists request/suspended.txt]} { set file [open request/suspended.txt w+]; close $file } if {[lindex [split $text] 0] == "" || [join [lrange [split $text] 1 end]] == "" || [string index [lindex [split $text] 0] 0] != "#"} { putquick "PRIVMSG $chan :(Request) $::lastbind <#channel> <reason>" } else { set file [open request/suspended.txt "r+"] set found 0 set suspendchan [lindex [split $text] 0] set suspendreason [join [lrange [split $text] 1 end]] while {![eof $file]} { set info [gets $file] if {[string equal -nocase "[lindex [split $info] 0]" $suspendchan]} { incr found 1 } } if {$found != "0"} { putquick "PRIVMSG $chan :(Request) Already suspended." } else { puts $file "$suspendchan $nick [strftime {%m/%d/%y}] $suspendreason" putquick "PRIVMSG $chan :(Request) Suspended." } close $file } } proc unsuspend {nick host hand chan text} { if {![file exists request/suspended.txt]} { putquick "PRIVMSG $chan :(Request) Couldn`t find the suspended channels list." } elseif {[lindex [split $text] 0] == "" || [string index [lindex [split $text] 0] 0] != "#"} { putquick "PRIVMSG $chan :(Request) $::lastbind <#channel>" } else { set file [open request/suspended.txt "r"] set found 0 set list {} set suspendchan [lindex [split $text] 0] while {![eof $file]} { set info [gets $file] if {[eof $file]} { break } if {[string equal -nocase "[lindex [split $info] 0]" $suspendchan]} { incr found 1 } else { lappend list [join [split $info]] } } close $file if {$found == "0"} { putquick "PRIVMSG $chan :(Request) $suspendchan is not suspended." } else { set file [open request/suspended.txt "w+"] foreach {info} $list { puts $file $info } close $file putquick "PRIVMSG $chan :(Request) $suspendchan has been removed from suspended list." } } } proc suspended {nick host hand chan text} { if {![file exists request/suspended.txt]} { putquick "PRIVMSG $chan :(Request) Couldn`t find the suspended channels list." } elseif {[lindex [split $text] 0] == "" || [string index [lindex [split $text] 0] 0] != "#"} { putquick "PRIVMSG $chan :(Request) $::lastbind <#channel>" } else { set file [open request/suspended.txt r] set buffer [split [read $file] \n] set suspendchan [lindex [split $text] 0] foreach info $buffer { if {[string equal -nocase "[lindex [split $info] 0]" $suspendchan]} { putquick "PRIVMSG $chan :(Request) \'[lindex [split $info] 0]\' has been suspended by ([lindex [split $info] 1]) on [lindex [split $info] 2] with reason: [join [lrange [split $info] 3 end]]" return } } putquick "PRIVMSG $chan :(Request) No info found about $suspendchan, not suspended." close $file } } } putlog "Request System ${request_system::reqversion} Is Scripted By 'Björn 'Turbo' B.'" </article> <article> <h1>[TCL] StatsScript für pisg</h1> UncleSam — Wed, 31 Jan 2007 20:05:59 +0100 Hi, so, nun nen script wo ich glaub dass es die Welt brauchen könnte Also dabei handelt es sich um ein script, das die pisg.cfg editiert je nach bedarf für die einzelnen Channels. Atm einstellbar für jeden channel einzeln (stand v2.14): - Sprache - Layout - Skin - On/Off natürlich Alles dadrüber findet ihr in meinem Forum. Sollte da immer up2date sein: <a href="forum.php?req=derefer&url=http%3A%2F%2Fwww.antenne-irc.de%2Findex.php%3Foption%3Dcom_joomlaboard%26Itemid%3D28%26func%3Dview%26id%3D4%26catid%3D5" title="http://www.antenne-irc.de/index.php?option=com_joomlaboard&Itemid=28&func=view&id=4&catid=5">Antenne-IRC.de Forum </a> Wünsche euch viel Spaß damit Euer UncleSam </article> <article> <h1>[Egg] Mediawiki/Wikipedia RC Announcer</h1> elven — Wed, 08 Nov 2006 17:14:29 +0100 $ svn co <a href="http://svn.swordcoast.net/tcl/trunk/mediawiki/">http://svn.swordcoast.net/tcl/trunk/mediawiki/</a> wikibot.tcl watches & announces the recent changes table on a MySQL-Mediawiki Installation. </article> <article> <h1>[EGG] Logtrim</h1> UncleSam — Wed, 21 Jun 2006 09:05:16 +0100 Hi, Mit dem script hier kann der Bot die Logs selbstständig auf die gewünschte größe trimmen. Alle Infos stehen im script. Wenn Fehler oder ähnliches auftauchen, dann bitte mir sagen <a href="mailto:UncleSam@Antenne-IRC.de">UncleSam@Antenne-IRC.de</a> oder #Antenne im Quakenet. Mfg UncleSam </article> <article> <h1>[EGG] Access</h1> Gotisch — Sat, 18 Feb 2006 14:00:32 +0100 This script will check Q-Auths against a Database with at least two columns, where one defines the auth and the other the channel the auth has access to. you can change access with the .access command (owners only) from the party line. I was writing this for Someone but only for one channel. So i though just in case someone needs something like that to expand it to multiple chans. [code] #Access (c) gotisch namespace eval Access { # Limit's Access to a Channel based on Q-Auth. # To check Q-Account we use: who nick n%nat,30 # Config: variable mysql array set mysql { pkg "" host "localhost" user "user" pass "pass" db "db" table "access" ncol "account" ccol "channel" } #No need to change that prob. variable num 100 variable chan "" #Channel flag setudef flag Access #Binds: bind join - * [namespace current]::OnJoin bind raw - 354 [namespace current]::OnRaw bind dcc n access [namespace current]::OnCommand #Procs: proc OnCommand { ha id te } { set args [split $te] if {[llength $args] < 3} { showhelp $id return } foreach {cmd auth chan} $args break; switch $cmd { "add" { if {![IsAllowed $auth $chan]} { Allow $auth $chan } putdcc $id "Done." } "remove" { if {[IsAllowed $auth $chan]} { UnAllow $auth $chan } putdcc $id "Done." } default { showhelp $id return } } } proc showhelp id { putdcc $id "Syntax is: .access <add/remove> <nick> <channel>" putdcc $id "Both can be masks so be carefull" putdcc $id "For example '.access remove somenick %' will remove all access of that user." } proc OnJoin { n uh ha ch } { variable num variable chan if {[isbotnick $n]} {return} if {![channel get $ch Access]} {return} putquick "WHO $n n%nat,$num" -next putlog "[namespace current]: Testing $n on $ch" set chan $ch } proc OnRaw { from keyword arguments } { variable num variable chan if {$keyword != 354} { return } putlog "[namespace current]: Got $arguments" set list1 [split $arguments] if {[lindex $list1 0] != $::botnick} { return } putlog "[namespace current]: For me [lindex $list1 0]" if {[lindex $list1 1] != $num} { return } putlog "[namespace current]: Right Query" if {![IsAllowed [lindex $list1 3] $chan]} { putlog "[namespace current]: Not Allowed" Remove [lindex $list1 2] $chan return } } proc IsAllowed {auth chan} { variable mysql if {$auth == "0"} { return 0 } putlog "[namespace current]: Authed as $auth" #1. Connect to Database: if { [ catch { set handle [mysqlconnect -host $mysql(host) -u $mysql(user) -password $mysql(pass) -db $mysql(db)] } err ] } { putlog "[namespace current]: Could not connect to MYSQL." return 1 } #2. We now have a valid mysql handle in $handle set result [mysqlsel $handle "SELECT `$mysql(ncol)` FROM `$mysql(table)` WHERE `$mysql(ncol)` LIKE '$auth' AND `$mysql(ccol)` LIKE '$chan'" -list] mysqlclose $handle putlog "[namespace current]: $result" if {$result == {}} { return 0 } return 1 } proc Allow { auth chan } { variable mysql if { [ catch { set handle [mysqlconnect -host $mysql(host) -u $mysql(user) -password $mysql(pass) -db $mysql(db)] } err ] } { putlog "[namespace current]: Could not connect to MYSQL." return 1 } putlog "[namespace current]:Allowing '$auth' to enter '$chan'" set result [mysqlexec $handle "INSERT INTO `$mysql(table)` ($mysql(ncol), $mysql(ccol)) VALUES ('$auth','$chan')"] putlog "[namespace current]: $result" } proc UnAllow { auth chan } { variable mysql if { [ catch { set handle [mysqlconnect -host $mysql(host) -u $mysql(user) -password $mysql(pass) -db $mysql(db)] } err ] } { putlog "[namespace current]: Could not connect to MYSQL." return 1 } putlog "[namespace current]: Removing '$auth's right to enter '$chan'" set result [mysqlexec $handle "DELETE FROM `$mysql(table)` WHERE `$mysql(ncol)` LIKE '$auth' AND `$mysql(ccol)` LIKE '$chan'"] putlog "[namespace current]: $result" } proc Remove {nick chan} { if {![channel get $chan Access]} { continue } if {![onchan $nick $chan]} { continue } newchanban $chan [maskhost [getchanhost $nick $chan]] [namespace current] "No Access - 10min ban" 10 sticky putkick $chan $nick "No Access - 10min ban" putlog "[namespace current]: Removing $nick from $chan. Reason: No Access" } proc ScriptLoad {} { variable mysql putlog "[namespace current]: Loading..." if { $mysql(pkg) == "" } { #No package set so we try to just require it. if { [catch { package require mysqltcl } err ] } { putlog "[namespace current]: Could not load mysql, unloading"; ScriptUnload; return } } else { #Mysqltcl should be a .so if { [catch { load $mysql(pkg) } err ] } { putlog "[namespace current]: Could not load mysql, unloading"; ScriptUnload; return } } putlog "[namespace current]: Done..." } #This never gets called manually. proc ScriptUnload {} { putlog "[namespace current]: Unloading..." foreach bind [binds [namespace current]*] { unbind [lindex $bind 0] [lindex $bind 1] [lindex $bind 2] [lindex $bind 4] } putlog "[namespace current]: Done..." namespace delete [namespace current] } #Start ScriptLoad } [/code] </article> <article> <h1>[EGG] Olympia Medaillenspiegel</h1> qzr|maniac — Sun, 12 Feb 2006 16:46:28 +0100 Heyho ihrs, hab mich gestern mal fix dran gesetzt und dieses mini script hier gebastelt. Und da die Spiele nur wenige Tage gehen, post ich es gleich mal hier, evtl gibt es Sportinteressierte die daran interesse haben. Beispielausgabe [code][01:22:48] <@qzr|maniac > !olympia [01:22:50] <@Marv1n > Platz / Land / Gold / Silber / Bronze / Ausbeute [01:22:52] <@Marv1n > 1 / Deutschland / 7 / 7 / 4 / 18 [01:22:54] <@Marv1n > 2 / USA / 7 / 5 / 3 / 15 [01:22:56] <@Marv1n > - / Österreich / 7 / 5 / 3 / 15 [01:22:58] <@Marv1n > 4 / Russland / 7 / 2 / 5 / 14 [01:23:00] <@Marv1n > 5 / Kanada / 3 / 6 / 5 / 14 [01:23:02] <@Marv1n > 6 / Südkorea / 3 / 3 / 1 / 7 [01:23:04] <@Marv1n > 7 / Frankreich / 3 / 1 / 2 / 6 [01:23:06] <@Marv1n > 8 / Italien / 3 / 0 / 4 / 7 [01:23:08] <@Marv1n > 9 / Estland / 3 / 0 / 0 / 3 [01:23:10] <@Marv1n > 10 / Norwegen / 2 / 7 / 8 / 17 [01:23:12] <@Marv1n > 11 / Schweiz / 2 / 2 / 4 / 8 [01:23:14] <@Marv1n > 12 / Schweden / 2 / 2 / 3 / 7 [01:23:15] <@Marv1n > 13 / Niederlande / 2 / 2 / 2 / 6 [01:23:17] <@Marv1n > 14 / China / 1 / 2 / 4 / 7 [01:23:19] <@Marv1n > 15 / Kroatien / 1 / 2 / 0 / [01:23:37] <@Marv1n > Der Medaillenspiegel basiert auf 54 von 84 Entscheidungen. [/code] grüsse Jens /edit Anzahl der Entscheidungen wurde hinzugefügt /edit² aktuelle Version <a href="forum.php?req=derefer&url=http%3A%2F%2F217.20.114.205%2Fdownload%2Folympia.tcl" title="http://217.20.114.205/download/olympia.tcl">http://217.20.114.205/download/olympia.tcl</a> PS: Es basiert auf einem snippet welches hier im Forum gepostet wurde, ich hab lediglich die auswertung und ausgabe geschrieben. </article> <article> <h1>[Site] Paste site</h1> CyBex — Mon, 05 Dec 2005 18:36:36 +0100 The paste site has now colors for syntax highlight.. <ul><li><a href="http://paste.tclhelp.net">http://paste.tclhelp.net</a></li></ul> Its now easier to find quote errors and wrong command.. Have fun and good luck ... </article> <article> <h1>[EGG] Leo</h1> CyBex — Thu, 01 Dec 2005 23:33:43 +0100 Mein Verbessertes LEO Script kann nun auch Deutsch<>Französisch, mit !leofr <wort> oder "!leo fr <wort>"... <a href="http://cybex.b0rk.de/files/tcl/powered/">http://cybex.b0rk.de/files/tcl/powered/</a> </article> <article> <h1>[EGG] TV Script (German stations)</h1> CyBex — Thu, 01 Dec 2005 23:31:23 +0100 Mit der Vorarbeit von thommey konnte ein sehr nettes TV Script entstehen, was einem 5 und direkt zum Start einer Sendung im IRC drauf aufmerksam macht... Und es funktioniert auch um 20:15, wo normalerweise die TV-Seiten überlastet sind, da es diese Information bereits irgendwann morgens holt. Nach dem ersten Start is das Script aber auch nich sofort Einsatzbereit, da es erstmal den Cache füllen muss. Dieses könnt ihr auf der Partyline verfolgen. Hier gehts zum Script: <a href="http://cybex.b0rk.de/files/tcl/powered/">http://cybex.b0rk.de/files/tcl/powered/</a> Eine kleine Anleitung vom Script (is auch oben der Kopf).. [quote]Hilfe: <ol> <li>!tv <sender> zeigt die nächsten Sendungen </li> <li>!tvsearch <suchwort> sucht halt überall im Namen nach diesem Suchwort </li> <li>!tvadd <sender> <sendung> fügt eine Sendung zur Beobachtungliste hinzu, die dann im Channel gemeldet wird. </li> <li>!tvdel <sender> <sendung> entfernt wieder Sendungen. </li> <li>!tvlist zeigt alle Sendung an, nach denen Ausschau gehalten wird. </li> <li>!addhaupt <sender> fügt einen Sender zu den Hauptsender hinzu </li> <li>!delaupt <sender> entfernt einen Sender von den Hauptsender </li> <li>!tvhaupt <sender> listet alle Hauptsender auf. </li> <li>!tv on/off schaltet das script im channel an/aus. </li> <li>!tv get zeigt die aktuellen Rechte/Flood/Hauptsender einstellung. </li> <li>!tv set <type> <wert> aendert die aktuelle einstellung, folgende typen sind erlaubt: allow, chanmodes, userflags, flood und haupt(sender). </li> </ol> Beispiele: <ol> <li>!tv rtl (listet die ndchsten 3 Sendung von RTL) </li> <li>!tv haupt (listet die aktuellen Sendungen von den Hauptsendern) </li> <li>!tv 2015 (listet die Hauptsender um 20:15 auf) </li> <li>!tv 23:45 (listet die Hauptsender um 23:45 auf) </li> <li>!tvsearch Simpsons (sucht nach den Simpsons) </li> <li>!tvadd pro7 Simpsons (f|gt die Simpsons zur Erinnerungsliste hinzu) </li> <li>!tvadd pro7 Family Guy (wie bei den Simpsons) </li> <li>!tvdel pro7 Simps (Entfernt das erste, was auf Simps was, vermutlich die Simpsons) </li> <li>!tvhaupt (listet alle Hauptsender auf) </li> <li>!addhaupt ard (f|gt Ard zu den Hauptsender hinzu) </li> <li>!delhaupt pro7 (lvscht Pro7 von den Hauptsendern) </li> <li>!tv set allow 5 (f|r Channelmodes und Userflags pr|fung) </li> <li>!tv set chanmodes op halfop (erlaubt nur f|r OPs die benutzung des TV-Scripts, sofern der Allow-Mode auf eine ChanMode pr|fung steht) </li> <li>!tv set userflags +nmol|+nmol (erlaubt nur f|r OPs oder grv_er die ..., sofern der Allow-Mode auf eine UserFlag pr|fung steht) </li> <li>!tv set flood 5:600 (erlaubt 5x in 10 minuten und antwortet danach als Notice und nicht mehr vffentlich) </li> <li>!tv set haupt ard zdf rbb (ersetzt alle Hauptsender aufeinmal, statt mit !addhaupt einzellne hinzuzuf|gen) </li> </ol> Config: <ol> <li>Und diese werte werden mehr oder weniger auch nur als default Einstellung für die Channels benutzt </li> <li>Danach wird alles dynamisch im Chanfile gespeichert bzw diese werte wer bei neu hinzugefügten Channels benutzt. </li> <li>Für spezielle Channel configuration benutzt den .chanset Befehl, zB: </li> <li>.chanset #chan tv-allow 4 </li> <li>.chanset #chan tv-chanmodes voice op </li> <li>.chanset #chan tv-userflags +vo-dq </li> <li>.chanset * tvflood 3:300 </li> <li>Wenn ihr nochmal alle Default(Global) einstellungen laden wollt, könnt ihr das wie folgt machen: </li> <li>.chanset * tv-allow 0 </li> <li>.chanset #chan tv-chanmodes </li> <li>.chanset * tv-userflags </li> <li>.chanset #chan2 tv-flood </li> <li>Alternativ kann man es mit !tv set <type> <wert> einstellen </li> </ol> global-tv-allow (digit) <ol> <li>1 = Alle dürfen und es wird auch kein Chanmode oder Userflag geprüft </li> <li>2 = Prüft die Chanmodes (isop, isvoice usw) </li> <li>3 = Prüft die Userflags im Bot (zB +m für master, -dq für alle die nicht voice oder op haben dürfen, +m-dq ein mix aus beidem) </li> <li>4 = Prüft die Chanmodes oder die Userflags, man braucht also eins von beidem </li> <li>5 = Prüft die Chanmodes und die Userflags, man braucht also beides </li> </ol> set global-tv-allow 1 global-tv-chan (string) <ol> <li>Prüft, wenn "allow" auf 1,3 oder 4 steht. </li> <li>default: voice halfop op </li> <li>Darf nie leer ("") sein, regelt das über den allow einsteller! (sonst erkennt der Bot nich, wann er default werte laden soll) </li> </ol> set global-tv-chanmodes "voice halfop op" global-tv-flags (string) <ol> <li>zB +m für master, -dq für alle die nicht voice oder op haben dürfen, +m-dq ein mix aus beidem </li> <li>* = muss beim Bot geadded sein, muss aber nich unbedingt flags haben. </li> <li>Darf nie leer ("") sein, regelt das über den allow einsteller! </li> <li>set global-tv-userflags "+nmolavgf-kdrq|+nmolavgf-kdrq" </li> </ol> set global-tv-userflags "*" global-tv-flood (digit:digit) <ol> <li>Anzahl:Zeit in sekunden, aus is, wenn eins von beidem auf 0 steht. </li> <li>3:1800 bedeutet, der Bot antwortet 3x öffentlich in 10 Minuten und schaltet dann automatisch die antwort direkt an Nick um </li> <li>set global-tv-flood 0:0 ; # aus </li> </ol> set global-tv-flood 3:1800 global-tv-haupt (string) <ol> <li>die default haupt sender </li> </ol> set global-tv-haupt "pro7 sat1 rtl rtl2 vox" tv-show-syntax (boolean 0/1) <ol> <li>bei !tv die syntax anzeigen oder gleich die Hauptsender? </li> </ol> set tv-show-syntax 0 <ol> <li>tv-master (string) </li> <li>flags die nötig sind, um Einstellungen zu verändert oder das Script an/aus zuschalten. </li> </ol> set tv-master "+nmol-kdrq|+nmol-kdrq" <ol> <li>tv-op (string) </li> <li>flags die nötig sind, um Sendungen/Sender zu verändern </li> </ol> set tv-op "+nmoavgfl-kdrq|+nmoavgfl-kdrq" <ol> <li>tv-trigger (char) </li> </ol> set tv-trigger "!"[/quote] Feedback wäre toll </article> <article> <h1>Role of this forum</h1> Mirage — Tue, 01 Jun 2004 13:34:36 +0100 This forum is made to allow you opening YOUR WORKING scripts to the public. To do this, simply create a new thread, put a short, significant description into the subject and a detailed one in the message. After all, append a link to your script. This forum is not for requesting help! </article> </main></body></html>