/usr/share/tcltk/tcllib1.14/irc/picoirc.tcl is in tcllib 1.14-dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 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 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | # 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.
# -------------------------------------------------------------------------
#
# $Id: picoirc.tcl,v 1.4 2008/06/24 22:06:56 patthoyts Exp $
namespace eval ::picoirc {
variable version 0.5.1
variable uid; if {![info exists uid]} { set uid 0 }
variable defaults {
server "irc.freenode.net"
port 6667
channel ""
callback ""
motd {}
users {}
}
namespace export connect send post splituri
}
proc ::picoirc::splituri {uri} {
foreach {server port channel} {{} {} {}} break
if {![regexp {^irc://([^:/]+)(?::([^/]+))?(?:/([^,]+))?} $uri -> server port channel]} {
regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channel server port
}
if {$port eq {}} { set port 6667 }
return [list $server $port $channel]
}
proc ::picoirc::connect {callback nick args} {
if {[llength $args] > 2} {
return -code error "wrong # args: must be \"callback nick ?passwd? url\""
} elseif {[llength $args] == 1} {
set url [lindex $args 0]
} else {
foreach {passwd url} $args break
}
variable defaults
variable uid
set context [namespace current]::irc[incr uid]
upvar #0 $context irc
array set irc $defaults
foreach {server port channel} [splituri $url] break
if {[info exists channel] && $channel ne ""} {set irc(channel) $channel}
if {[info exists server] && $server ne ""} {set irc(server) $server}
if {[info exists port] && $port ne ""} {set irc(port) $port}
if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd}
set irc(callback) $callback
set irc(nick) $nick
Callback $context init
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} err]} {
puts stderr "callback error: $err"
}
}
}
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 ""} {
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"
if {$irc(channel) ne {}} {
after idle [list [namespace origin send] $context "JOIN $irc(channel)"]
}
return
}
proc ::picoirc::Splitirc {s} {
foreach v {nick flags user host} {set $v {}}
regexp {^([^!]*)!([^=]*)=([^@]+)@(.*)} $s -> nick flags user host
return [list $nick $flags $user $host]
}
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
}
}
Callback $context chat $target $nick $msg $type
} elseif {[regexp {^:((?:([^ ]+) +){1,}?):(.*)$} $line -> parts junk rest]} {
foreach {server code target fourth fifth} [split $parts] break
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 {
foreach {server code target nick name host x} [split $parts] break
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 {
foreach {n f u h} [Splitirc $server] break
Callback $context traffic entered $rest $n
return
}
NICK {
foreach {n f u h} [Splitirc $server] break
Callback $context traffic nickchange {} $n $rest
return
}
QUIT - PART {
foreach {n f u h} [Splitirc $server] break
Callback $context traffic left $target $n
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
set type ""
if [regexp {^/([^ ]+) *(.*)} $msg -> cmd msg] {
regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest
switch -- $cmd {
me {set msg "\001ACTION $msg\001";set type ACTION}
nick {send $context "NICK $msg"; set $irc(nick) $msg}
quit {send $context "QUIT" }
part {send $context "PART $channel" }
names {send $context "NAMES $channel"}
whois {send $context "WHOIS $channel $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 {
if {[regexp {([^ ]+) +(.*)} $msg -> target querymsg]} {
send $context "PRIVMSG $target :$msg"
Callback $context chat $target $target $querymsg ""
}
}
default {Callback $context system $channel "unknown command /$cmd"}
}
if {$cmd ne {me} || $cmd eq {msg}} return
}
foreach line [split $msg \n] {send $context "PRIVMSG $channel :$line"}
Callback $context chat $channel $irc(nick) $msg $type
}
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 $::picoirc::version
# -------------------------------------------------------------------------
|