Posted to tcl by dbohdan at Sat May 15 16:05:23 GMT 2021view raw

  1. # Based upon the picoirc code by Salvatore Sanfillipo and Richard Suchenwirth
  2. # See http://wiki.tcl.tk/13134 for the original standalone version.
  3. #
  4. # This package provides a general purpose minimal IRC client suitable for
  5. # embedding in other applications. All communication with the parent
  6. # application is done via an application provided callback procedure.
  7. #
  8. # Copyright (c) 2004 Salvatore Sanfillipo
  9. # Copyright (c) 2004 Richard Suchenwirth
  10. # Copyright (c) 2007 Patrick Thoyts
  11. #
  12. # -------------------------------------------------------------------------
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. # -------------------------------------------------------------------------
  16.  
  17. package require Tcl 8.6
  18.  
  19. # -------------------------------------------------------------------------
  20.  
  21. namespace eval ::picoirc {
  22. variable uid
  23. if {![info exists uid]} { set uid 0 }
  24.  
  25. variable defaults {
  26. server "irc.freenode.net"
  27. port 6667
  28. secure 0
  29. channels ""
  30. callback ""
  31. motd {}
  32. users {}
  33. keys {}
  34. }
  35. namespace export connect send post splituri
  36. }
  37.  
  38. proc ::picoirc::splituri {uri} {
  39. lassign {{} {} {} {}} secure server port channels
  40. if {![regexp {^irc(s)?://([^:/]+)(?::([^/]+))?(?:/([^ ]+))?} $uri -> secure server port channels]} {
  41. regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channels server port
  42. }
  43. set secure [expr {$secure eq "s"}]
  44.  
  45. set channels [lmap x [split $channels ,] {
  46. # Filter out parameters that are special according to the IRC URL
  47. # scheme Internet-Draft.
  48. if {$x in {needkey needpass}} continue
  49. set x
  50. }]
  51. if {[llength $channels] == 1} {
  52. set channels [lindex $channels 0]
  53. }
  54.  
  55. if {$port eq {}} { set port [expr {$secure ? 6697: 6667}] }
  56. return [list $server $port $channels $secure]
  57. }
  58.  
  59. proc ::picoirc::connect args {
  60. switch [llength $args] {
  61. 3 { lassign $args callback nick url }
  62. 4 { lassign $args callback nick passwd url }
  63. 5 { lassign $args callback nick passwd url keys }
  64. default {
  65. return -code error "wrong # args: must be \"callback nick\
  66. ?passwd? url ?channel-keys?\""
  67. }
  68. }
  69. variable defaults
  70. variable uid
  71. set context [namespace current]::irc[incr uid]
  72. upvar #0 $context irc
  73. array set irc $defaults
  74. lassign [splituri $url] server port channels secure
  75. if {[info exists channels] && $channels ne ""} {set irc(channels) $channels}
  76. if {[info exists server] && $server ne ""} {set irc(server) $server}
  77. if {[info exists port] && $port ne ""} {set irc(port) $port}
  78. if {[info exists secure] && $secure} {set irc(secure) $secure}
  79. if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd}
  80. if {[info exists keys] && $keys ne ""} {set irc(keys) $keys}
  81. set irc(callback) $callback
  82. set irc(nick) $nick
  83. Callback $context init
  84. if {$irc(secure)} {
  85. set irc(socket) [::tls::socket $irc(server) $irc(port)]
  86. } else {
  87. set irc(socket) [socket -async $irc(server) $irc(port)]
  88. }
  89. fileevent $irc(socket) readable [list [namespace origin Read] $context]
  90. fileevent $irc(socket) writable [list [namespace origin Write] $context]
  91. return $context
  92. }
  93.  
  94. proc ::picoirc::Callback {context state args} {
  95. upvar #0 $context irc
  96. if {[llength $irc(callback)] > 0
  97. && [llength [info commands [lindex $irc(callback) 0]]] == 1} {
  98. if {[catch {eval $irc(callback) [list $context $state] $args} result]} {
  99. puts stderr "callback error: $result"
  100. } else {
  101. return $result
  102. }
  103. }
  104. }
  105.  
  106. proc ::picoirc::Version {context} {
  107. if {[catch {Callback $context version} ver]} { set ver {} }
  108. if {$ver eq {}} {
  109. set ver "PicoIRC:[package provide picoirc]:Tcl [info patchlevel]"
  110. }
  111. return $ver
  112. }
  113.  
  114. proc ::picoirc::Write {context} {
  115. upvar #0 $context irc
  116. fileevent $irc(socket) writable {}
  117. if {[set err [fconfigure $irc(socket) -error]] ne ""
  118. || $irc(secure) && [catch {while {![::tls::handshake $irc(socket)]} {}} err] != 0} {
  119. Callback $context close $err
  120. close $irc(socket)
  121. unset irc
  122. return
  123. }
  124. fconfigure $irc(socket) -blocking 0 -buffering line -translation crlf -encoding utf-8
  125. Callback $context connect
  126. if {[info exists irc(passwd)]} {
  127. send $context "PASS $irc(passwd)"
  128. }
  129. set ver [join [lrange [split [Version $context] :] 0 1] " "]
  130. send $context "NICK $irc(nick)"
  131. send $context "USER $::tcl_platform(user) 0 * :$ver user"
  132. foreach channel $irc(channels) key $irc(keys) {
  133. set command "JOIN $channel"
  134. if {$key ne {}} {
  135. append command " $key"
  136. }
  137. after idle [list [namespace origin send] $context $command]
  138. }
  139. return
  140. }
  141.  
  142. proc ::picoirc::Getnick {s} {
  143. set nick {}
  144. regexp {^([^!]*)!} $s -> nick
  145. return $nick
  146. }
  147.  
  148. proc ::picoirc::Read {context} {
  149. upvar #0 $context irc
  150. if {[eof $irc(socket)]} {
  151. fileevent $irc(socket) readable {}
  152. Callback $context close
  153. close $irc(socket)
  154. unset irc
  155. return
  156. }
  157. if {[gets $irc(socket) line] != -1} {
  158. if {[string match "PING*" $line]} {
  159. send $context "PONG [info hostname] [lindex [split $line] 1]"
  160. return
  161. }
  162. # the callback can return -code break to prevent processing the read
  163. if {[catch {Callback $context debug read $line}] == 3} {
  164. return
  165. }
  166. if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
  167. nick target msg]} {
  168. set type ""
  169. if {[regexp {^\001(\S+)(?: (.*))?\001$} $msg -> ctcp data]} {
  170. switch -- $ctcp {
  171. ACTION { set type ACTION ; set msg $data }
  172. VERSION {
  173. send $context "NOTICE $nick :\001VERSION [Version $context]\001"
  174. return
  175. }
  176. PING {
  177. send $context "NOTICE $nick :\001PING [lindex $data 0]\001"
  178. return
  179. }
  180. TIME {
  181. set time [clock format [clock seconds] \
  182. -format {%a %b %d %H:%M:%S %Y %Z}]
  183. send $context "NOTICE $nick :\001TIME $time\001"
  184. return
  185. }
  186. default {
  187. set err [string map [list \001 ""] $msg]
  188. send $context "NOTICE $nick :\001ERRMSG $err : unknown query\001"
  189. return
  190. }
  191. }
  192. }
  193. if {[lsearch -exact {ijchain wubchain} $nick] != -1} {
  194. if {$type eq "ACTION"} {
  195. regexp {(\S+) (.+)} $msg -> nick msg
  196. } else {
  197. regexp {<([^>]+)> (.+)} $msg -> nick msg
  198. }
  199. }
  200. if {$irc(nick) == $target} {set target $nick}
  201. Callback $context chat $target $nick $msg $type
  202. } elseif {[regexp {^:([^ ]+(?: +([^ :]+))*)(?: :(.*))?} $line -> parts junk rest]} {
  203. lassign [split $parts] server code target fourth fifth
  204. switch -- $code {
  205. 001 - 002 - 003 - 004 - 005 - 250 - 251 - 252 -
  206. 254 - 255 - 265 - 266 { return }
  207. 433 {
  208. variable nickid ; if {![info exists nickid]} {set nickid 0}
  209. set seqlen [string length [incr nickid]]
  210. set irc(nick) [string range $irc(nick) 0 [expr 8-$seqlen]]$nickid
  211. send $context "NICK $irc(nick)"
  212. }
  213. 353 { set irc(users) [concat $irc(users) $rest]; return }
  214. 366 {
  215. Callback $context userlist $fourth $irc(users)
  216. set irc(users) {}
  217. return
  218. }
  219. 332 { Callback $context topic $fourth $rest; return }
  220. 333 { return }
  221. 375 { set irc(motd) {} ; return }
  222. 372 { append irc(motd) $rest ; return}
  223. 376 { return }
  224. 311 {
  225. lassign [split $parts] server code target nick name host x
  226. set irc(whois,$fourth) [list name $name host $host userinfo $rest]
  227. return
  228. }
  229. 301 - 312 - 317 - 320 { return }
  230. 319 { lappend irc(whois,$fourth) channels $rest; return }
  231. 318 {
  232. if {[info exists irc(whois,$fourth)]} {
  233. Callback $context userinfo $fourth $irc(whois,$fourth)
  234. unset irc(whois,$fourth)
  235. }
  236. return
  237. }
  238. JOIN {
  239. set nick [Getnick $server]
  240. Callback $context traffic entered $target $nick
  241. return
  242. }
  243. NICK {
  244. set nick [Getnick $server]
  245. if {$irc(nick) == $nick} {set irc(nick) $rest}
  246. Callback $context traffic nickchange {} $nick $rest
  247. return
  248. }
  249. QUIT - PART {
  250. set nick [Getnick $server]
  251. Callback $context traffic left $target $nick
  252. return
  253. }
  254. MODE {
  255. set nick [Getnick $server]
  256. if {$fourth != ""} {
  257. Callback $context mode $nick $target "$fourth $fifth"
  258. } else {
  259. Callback $context mode $nick $target $rest
  260. }
  261. return
  262. }
  263. NOTICE {
  264. if {$target in [list $irc(nick) *]} {
  265. set target {}
  266. }
  267. Callback $context chat $target [Getnick $server] $rest NOTICE
  268. return
  269. }
  270. }
  271. Callback $context system "" "[lrange [split $parts] 1 end] $rest"
  272. } else {
  273. Callback $context system "" $line
  274. }
  275. }
  276. }
  277.  
  278. proc ::picoirc::post {context channel msg} {
  279. upvar #0 $context irc
  280. foreach line [split $msg \n] {
  281. if [regexp {^/([^ ]+) *(.*)} $line -> cmd msg] {
  282. regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest
  283. switch -- $cmd {
  284. me {
  285. if {$channel eq ""} {
  286. Callback $context system "" "not in channel"
  287. continue
  288. }
  289. send $context "PRIVMSG $channel :\001ACTION $msg\001"
  290. Callback $context chat $channel $irc(nick) $msg ACTION
  291. }
  292. nick {send $context "NICK $msg"}
  293. quit {send $context "QUIT"}
  294. part {send $context "PART $channel"}
  295. names {send $context "NAMES $channel"}
  296. whois {send $context "WHOIS $msg"}
  297. kick {send $context "KICK $channel $first :$rest"}
  298. mode {send $context "MODE $msg"}
  299. topic {send $context "TOPIC $channel :$msg"}
  300. quote {send $context $msg}
  301. join {send $context "JOIN $msg"}
  302. version {send $context "PRIVMSG $first :\001VERSION\001"}
  303. msg - notice {
  304. set type [expr {$cmd == "msg" ? "" : "NOTICE"}]
  305. set cmd [expr {$cmd == "msg" ? "PRIVMSG" : "NOTICE"}]
  306. send $context "$cmd $first :$rest"
  307. Callback $context chat $first $irc(nick) $rest $type
  308. }
  309. default {Callback $context system $channel "unknown command /$cmd"}
  310. }
  311. continue
  312. }
  313. if {$channel eq ""} {
  314. Callback $context system "" "not in channel"
  315. continue
  316. }
  317. send $context "PRIVMSG $channel :$line"
  318. Callback $context chat $channel $irc(nick) $line
  319. }
  320. }
  321.  
  322. proc ::picoirc::send {context line} {
  323. upvar #0 $context irc
  324. # the callback can return -code break to prevent writing to socket
  325. if {[catch {Callback $context debug write $line}] != 3} {
  326. puts $irc(socket) $line
  327. }
  328. }
  329.  
  330. # -------------------------------------------------------------------------
  331.  
  332. package provide picoirc 0.10.0
  333.  
  334. # -------------------------------------------------------------------------
  335. return