[Richard Suchenwirth] 2007-12-19 - I love the [Tcl chatroom]. It's like my peer group. So I was quite frustrated when good old Ralfchat (a [Perl] script) on `mini.net` was closed down, because that was my only way to participate in the chat from my cellphone. But isn't Tcl an enabling language? Why not put useful parts from [picoIRC 0.2] and [Playing CGI] together, and build my own bridge between [IRC] and [http]? The following script connects to IRC (you may have to fumble with the ircnick, if it is reported as being in use) and collects what is posted to the #tcl channel. It also provides a web server that listens on port 80, and provides the latest posts to the customer there. Also, it accepts posts and posts them to #tcl... It's all quite crude, but what do you expect from less than 90 lines of code, depending on nothing but [Tcl]? At least, it works quite well from my cell phone, so I can chat from that again (if a server is started). Here goes: ---- #!/usr/bin/env tclsh # webchain.tcl - HTTP <-> IRC bridge set port 80 set encoding iso8859-1 ;# utf-8 set nick someone set ircserver irc.freenode.org set ircport 6667 set chan #tcl set ircnick webchain set log {webchain Welcome.} proc irc_recv {} { gets $::fd line if {[string trim $line] ne ""} {puts $line} # handle PING messages from server if {[lindex [split $line] 0] eq "PING"} { send "PONG [info hostname] [lindex [split $line] 1]"; return } if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \ nick target msg]} { set tag "" if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic} if [in {azbridge ijchain} $nick] { regexp {<([^>]+)>(.+)} $msg -> nick msg } if {$tag eq "italic"} {set msg $msg} lappend ::log $nick $msg } else {lappend ::log - $line} } proc in {list element} {expr {[lsearch -exact $list $element]>=0}} proc post msg { if [regexp {^/me (.+)} $msg -> action] {set msg "\001ACTION $action\001"} foreach line [split $msg \n] {send "PRIVMSG $::chan :<$::nick> $line"} } proc send str {puts $::fd $str; flush $::fd} proc answer {sock host2 port2} { fileevent $sock readable [list serve $sock] } proc encmap enc {string map {utf- UTF iso ISO-} $enc} proc serve sock { fconfigure $sock -blocking 0 -encoding $::encoding gets $sock line if {[fblocked $sock]} return fileevent $sock readable "" set args "" regexp {(/[^ ?]*)\??([^ ]*)?} $line -> tail args puts $sock "HTTP/1.0 200 OK" puts $sock "Content-Type: text/html;charset=$[encmap $::encoding]\n" puts $sock webchain array set a [concat {MSG "" NICK "" CNT 30} [kvsplit $args]] if {$a(MSG) ne ""} { lappend ::log $a(NICK) $a(MSG) set ::log [lrange $::log end-999 end] set ::nick $a(NICK) post $a(MSG) } foreach {nick post} [lrange $::log end-[expr {$a(CNT)*2-1}] end] { puts $sock "$nick: $post
" } puts $sock "

Nick: Lines:
" puts $sock close $sock } proc kvsplit kv { set res "" foreach i [split $kv &] { foreach {k v} [split $i =] break lappend res $k [unescape $v] } set res } proc unescape str { regsub -all {%(..)} [string map {+ " "} $str] {\u00\1} str subst $str } #-- connect to IRC... set ::fd [socket $::ircserver $::ircport] send "NICK $::ircnick" send "USER $::ircnick 0 * :Tcl user" send "JOIN $::chan" fileevent $::fd readable irc_recv socket -server answer $port puts "Server ready..." vwait forever ---- [jdc] I made some changes to the original scripts from [RS]: * Quoted special html characters * Set encoding of IRC channel to utf-8 * Convert data posted by browser to utf-8 * Added headers to pass W3C xhtml validation and to make the Nokia xhtml browser work * Added error when posting without specifying a nick name * Added logging * Added coloring of your own posts ====== #!/usr/bin/env tclsh # webchain.tcl - HTTP <-> IRC bridge lappend auto_path /target/staff/decoster/activetcl/8.4.11.2/lib package require html set port 80 set encoding iso8859-1 ;# utf-8 set nick someone set ircserver irc.freenode.org set ircport 6667 set chan #tcl set ircnick webchain set log {webchain Welcome.} proc irc_recv {} { gets $::fd line string trim $line # handle PING messages from server if {[lindex [split $line] 0] eq "PING"} { send "PONG [info hostname] [lindex [split $line] 1]"; return } if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \ nick target msg]} { set tag "" if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic} if [in {azbridge ijchain} $nick] { regexp {<([^>]+)>(.+)} $msg -> nick msg } if {$tag eq "italic"} { lappend ::log [::html::quoteFormValue $nick] [::html::quoteFormValue $msg] } else { lappend ::log [::html::quoteFormValue $nick] [::html::quoteFormValue $msg] } } else {lappend ::log - [::html::quoteFormValue $line]} } proc in {list element} {expr {[lsearch -exact $list $element]>=0}} proc post msg { if [regexp {^/me (.+)} $msg -> action] { foreach line [split $action \n] {send "PRIVMSG $::chan :* $::nick $line"} } else { foreach line [split $msg \n] {send "PRIVMSG $::chan :<$::nick> $line"} } } proc send str { puts $::fd $str; flush $::fd } proc answer {sock host2 port2} { fileevent $sock readable [list serve $sock $host2 $port2] } proc encmap enc {string map {utf- UTF iso ISO-} $enc} proc serve {sock host2 port2} { fconfigure $sock -blocking 0 -encoding utf-8 gets $sock line if {[fblocked $sock]} return fileevent $sock readable "" set args "" regexp {(/[^ ?]*)\??([^ ]*)?} $line -> tail args puts $sock "HTTP/1.0 200 OK" puts $sock "Content-Type: text/html;charset=UTF-8\n" puts $sock "" puts $sock "webchain" puts $sock "" puts $sock "Flying pig productions" array set a [concat {MSG "" NICK "" CNT 30} [kvsplit $args]] if {![string is integer -strict $a(CNT)]} { set a(CNT) 30 } set a(NICK) [string map {" " _} $a(NICK)] if {$a(NICK) ne ""} { set enick [::html::quoteFormValue $a(NICK)] if {$a(MSG) ne ""} { if [regexp {^/me (.+)} $a(MSG) -> action] { lappend ::log $enick [::html::quoteFormValue $action] } else { lappend ::log $enick [::html::quoteFormValue $a(MSG)] } set ::log [lrange $::log end-999 end] set ::nick $a(NICK) puts $::logf "[clock seconds] $sock $host2 $port2 $a(NICK) $a(MSG)" flush $::logf post $a(MSG) set a(MSG) "" } foreach {nick post} [lrange $::log end-[expr {$a(CNT)*2-1}] end] { if {$nick eq $enick} { set style my_posts } else { set style other_posts } puts $sock "$nick: $post
" } } else { puts $sock "

You can not post without entering a nick name!

" } puts $sock "
" puts $sock "

" puts $sock "

Nick: " puts $sock "Lines: " puts $sock "

" puts $sock close $sock } proc kvsplit kv { set res "" foreach i [split $kv &] { foreach {k v} [split $i =] break lappend res $k [unescape $v] } set res } proc unescape str { set str [string map [list + { } "\\" "\\\\"] $str] regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str set str [subst -novariable -nocommand $str] set str [encoding convertfrom utf-8 $str] string trim $str } #-- connect to IRC... set logf [open webchain[clock seconds].log w] set ::fd [socket $::ircserver $::ircport] fconfigure $::fd -encoding utf-8 send "NICK $::ircnick" send "USER $::ircnick 0 * :Tcl user" send "JOIN $::chan" fileevent $::fd readable irc_recv socket -server answer $port puts "Server ready..." vwait forever ====== ---- !!!!!! %| [Category Example] | [Category Internet] |% !!!!!!