Posted to tcl by dbohdan at Sat May 15 17:09:55 GMT 2021view pretty
# usage: picoirc::connect nick {} url {} {{/msg NickServ IDENTIFY nickagain password}}
# Based upon the picoirc code by Salvatore Sanfillipo and Richard Suchenwirth
# See http://wiki.tcl.tk/13134 for the original standalone version.
#
# This package provides a general purpose minimal IRC client suitable for
# embedding in other applications. All communication with the parent
# application is done via an application provided callback procedure.
#
# Copyright (c) 2004 Salvatore Sanfillipo
# Copyright (c) 2004 Richard Suchenwirth
# Copyright (c) 2007 Patrick Thoyts
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
package require Tcl 8.6
# -------------------------------------------------------------------------
namespace eval ::picoirc {
variable uid
if {![info exists uid]} { set uid 0 }
variable defaults {
server "irc.freenode.net"
port 6667
secure 0
channels ""
callback ""
motd {}
users {}
keys {}
authcmds {}
}
namespace export connect send post splituri
}
proc ::picoirc::splituri {uri} {
lassign {{} {} {} {}} secure server port channels
if {![regexp {^irc(s)?://([^:/]+)(?::([^/]+))?(?:/([^ ]+))?} $uri -> secure server port channels]} {
regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channels server port
}
set secure [expr {$secure eq "s"}]
set channels [lmap x [split $channels ,] {
# Filter out parameters that are special according to the IRC URL
# scheme Internet-Draft.
if {$x in {needkey needpass}} continue
set x
}]
if {[llength $channels] == 1} {
set channels [lindex $channels 0]
}
if {$port eq {}} { set port [expr {$secure ? 6697: 6667}] }
return [list $server $port $channels $secure]
}
proc ::picoirc::connect args {
switch [llength $args] {
3 { lassign $args callback nick url }
4 { lassign $args callback nick passwd url }
5 { lassign $args callback nick passwd url keys }
6 { lassign $args callback nick passwd url keys authcmds }
default {
return \
-code error \
"wrong # args: must be \"callback nick ?passwd? url\
?channel-keys? ?auth-commands?\""
}
}
variable defaults
variable uid
set context [namespace current]::irc[incr uid]
upvar #0 $context irc
array set irc $defaults
lassign [splituri $url] server port channels secure
if {[info exists channels] && $channels ne ""} {set irc(channels) $channels}
if {[info exists server] && $server ne ""} {set irc(server) $server}
if {[info exists port] && $port ne ""} {set irc(port) $port}
if {[info exists secure] && $secure} {set irc(secure) $secure}
if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd}
if {[info exists keys] && $keys ne ""} {set irc(keys) $keys}
if {[info exists authcmds] && $authcmds ne ""} {set irc(authcmds) $authcmds}
set irc(callback) $callback
set irc(nick) $nick
Callback $context init
if {$irc(secure)} {
set irc(socket) [::tls::socket $irc(server) $irc(port)]
} else {
set irc(socket) [socket -async $irc(server) $irc(port)]
}
fileevent $irc(socket) readable [list [namespace origin Read] $context]
fileevent $irc(socket) writable [list [namespace origin Write] $context]
return $context
}
proc ::picoirc::Callback {context state args} {
upvar #0 $context irc
if {[llength $irc(callback)] > 0
&& [llength [info commands [lindex $irc(callback) 0]]] == 1} {
if {[catch {eval $irc(callback) [list $context $state] $args} result]} {
puts stderr "callback error: $result"
} else {
return $result
}
}
}
proc ::picoirc::Version {context} {
if {[catch {Callback $context version} ver]} { set ver {} }
if {$ver eq {}} {
set ver "PicoIRC:[package provide picoirc]:Tcl [info patchlevel]"
}
return $ver
}
proc ::picoirc::Write {context} {
upvar #0 $context irc
fileevent $irc(socket) writable {}
if {[set err [fconfigure $irc(socket) -error]] ne ""
|| $irc(secure) && [catch {while {![::tls::handshake $irc(socket)]} {}} err] != 0} {
Callback $context close $err
close $irc(socket)
unset irc
return
}
fconfigure $irc(socket) -blocking 0 -buffering line -translation crlf -encoding utf-8
Callback $context connect
if {[info exists irc(passwd)]} {
send $context "PASS $irc(passwd)"
}
set ver [join [lrange [split [Version $context] :] 0 1] " "]
send $context "NICK $irc(nick)"
send $context "USER $::tcl_platform(user) 0 * :$ver user"
foreach command $irc(authcmds) {
after idle [list [namespace origin post] $context {} $command]
}
foreach channel $irc(channels) key $irc(keys) {
set command "JOIN $channel"
if {$key ne {}} {
append command " $key"
}
after idle [list [namespace origin send] $context $command]
}
return
}
proc ::picoirc::Getnick {s} {
set nick {}
regexp {^([^!]*)!} $s -> nick
return $nick
}
proc ::picoirc::Read {context} {
upvar #0 $context irc
if {[eof $irc(socket)]} {
fileevent $irc(socket) readable {}
Callback $context close
close $irc(socket)
unset irc
return
}
if {[gets $irc(socket) line] != -1} {
if {[string match "PING*" $line]} {
send $context "PONG [info hostname] [lindex [split $line] 1]"
return
}
# the callback can return -code break to prevent processing the read
if {[catch {Callback $context debug read $line}] == 3} {
return
}
if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
nick target msg]} {
set type ""
if {[regexp {^\001(\S+)(?: (.*))?\001$} $msg -> ctcp data]} {
switch -- $ctcp {
ACTION { set type ACTION ; set msg $data }
VERSION {
send $context "NOTICE $nick :\001VERSION [Version $context]\001"
return
}
PING {
send $context "NOTICE $nick :\001PING [lindex $data 0]\001"
return
}
TIME {
set time [clock format [clock seconds] \
-format {%a %b %d %H:%M:%S %Y %Z}]
send $context "NOTICE $nick :\001TIME $time\001"
return
}
default {
set err [string map [list \001 ""] $msg]
send $context "NOTICE $nick :\001ERRMSG $err : unknown query\001"
return
}
}
}
if {[lsearch -exact {ijchain wubchain} $nick] != -1} {
if {$type eq "ACTION"} {
regexp {(\S+) (.+)} $msg -> nick msg
} else {
regexp {<([^>]+)> (.+)} $msg -> nick msg
}
}
if {$irc(nick) == $target} {set target $nick}
Callback $context chat $target $nick $msg $type
} elseif {[regexp {^:([^ ]+(?: +([^ :]+))*)(?: :(.*))?} $line -> parts junk rest]} {
lassign [split $parts] server code target fourth fifth
switch -- $code {
001 - 002 - 003 - 004 - 005 - 250 - 251 - 252 -
254 - 255 - 265 - 266 { return }
433 {
variable nickid ; if {![info exists nickid]} {set nickid 0}
set seqlen [string length [incr nickid]]
set irc(nick) [string range $irc(nick) 0 [expr 8-$seqlen]]$nickid
send $context "NICK $irc(nick)"
}
353 { set irc(users) [concat $irc(users) $rest]; return }
366 {
Callback $context userlist $fourth $irc(users)
set irc(users) {}
return
}
332 { Callback $context topic $fourth $rest; return }
333 { return }
375 { set irc(motd) {} ; return }
372 { append irc(motd) $rest ; return}
376 { return }
311 {
lassign [split $parts] server code target nick name host x
set irc(whois,$fourth) [list name $name host $host userinfo $rest]
return
}
301 - 312 - 317 - 320 { return }
319 { lappend irc(whois,$fourth) channels $rest; return }
318 {
if {[info exists irc(whois,$fourth)]} {
Callback $context userinfo $fourth $irc(whois,$fourth)
unset irc(whois,$fourth)
}
return
}
JOIN {
set nick [Getnick $server]
Callback $context traffic entered $target $nick
return
}
NICK {
set nick [Getnick $server]
if {$irc(nick) == $nick} {set irc(nick) $rest}
Callback $context traffic nickchange {} $nick $rest
return
}
QUIT - PART {
set nick [Getnick $server]
Callback $context traffic left $target $nick
return
}
MODE {
set nick [Getnick $server]
if {$fourth != ""} {
Callback $context mode $nick $target "$fourth $fifth"
} else {
Callback $context mode $nick $target $rest
}
return
}
NOTICE {
if {$target in [list $irc(nick) *]} {
set target {}
}
Callback $context chat $target [Getnick $server] $rest NOTICE
return
}
}
Callback $context system "" "[lrange [split $parts] 1 end] $rest"
} else {
Callback $context system "" $line
}
}
}
proc ::picoirc::post {context channel msg} {
upvar #0 $context irc
foreach line [split $msg \n] {
if [regexp {^/([^ ]+) *(.*)} $line -> cmd msg] {
regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest
switch -- $cmd {
me {
if {$channel eq ""} {
Callback $context system "" "not in channel"
continue
}
send $context "PRIVMSG $channel :\001ACTION $msg\001"
Callback $context chat $channel $irc(nick) $msg ACTION
}
nick {send $context "NICK $msg"}
quit {send $context "QUIT"}
part {send $context "PART $channel"}
names {send $context "NAMES $channel"}
whois {send $context "WHOIS $msg"}
kick {send $context "KICK $channel $first :$rest"}
mode {send $context "MODE $msg"}
topic {send $context "TOPIC $channel :$msg"}
quote {send $context $msg}
join {send $context "JOIN $msg"}
version {send $context "PRIVMSG $first :\001VERSION\001"}
msg - notice {
set type [expr {$cmd == "msg" ? "" : "NOTICE"}]
set cmd [expr {$cmd == "msg" ? "PRIVMSG" : "NOTICE"}]
send $context "$cmd $first :$rest"
Callback $context chat $first $irc(nick) $rest $type
}
default {Callback $context system $channel "unknown command /$cmd"}
}
continue
}
if {$channel eq ""} {
Callback $context system "" "not in channel"
continue
}
send $context "PRIVMSG $channel :$line"
Callback $context chat $channel $irc(nick) $line
}
}
proc ::picoirc::send {context line} {
upvar #0 $context irc
# the callback can return -code break to prevent writing to socket
if {[catch {Callback $context debug write $line}] != 3} {
puts $irc(socket) $line
}
}
# -------------------------------------------------------------------------
package provide picoirc 0.10.0
# -------------------------------------------------------------------------
return