Posted to tcl by dbohdan at Sat May 15 17:09:55 GMT 2021view raw

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