Posted to tcl by Stu at Sat May 10 03:02:34 GMT 2008view raw

  1. # herring
  2. #
  3. # May 2008
  4. # Stuart Cassoff
  5. #
  6. # Use at your own risk
  7. # (many have died)
  8. #
  9.  
  10. namespace eval herring {
  11. variable HookUserInfoDialog 0
  12. variable InfoRaw 0
  13. variable TwigRun 0
  14.  
  15. variable cfg
  16.  
  17. set cfg(version) 0.1
  18.  
  19. set cfg(tclsh) /usr/local/bin/tclsh8.5
  20. set cfg(wish) /usr/local/bin/wish8.5
  21. set cfg(twig) ~/tcl/twig/twig.tcl
  22. set cfg(run) $cfg(wish)
  23.  
  24. set cfg(myTwigListFile) ~/twiglist.twig
  25.  
  26. set cfg(twigs) {}
  27.  
  28. # Chat Text Window
  29. set cfg(ctw) .txt
  30.  
  31. set cfg(aliasMap) [list \
  32. wikiref ::herring::wikiref \
  33. twig ::herring::twig \
  34. ]
  35.  
  36. set cfg(floodcount) 0
  37. set cfg(floodmax) 15
  38.  
  39.  
  40. }
  41.  
  42. proc herring::wikisearch {what {max -1}} {
  43. set z {}
  44. set c 0
  45. set h [http::geturl http://wiki.tcl.tk/_search?S=$what]
  46. if {[http::status $h] eq {ok}} {
  47. foreach {. p n} [regexp -inline -all {<li>.*?\. \. \. <a href="/(.*?)">(.*?)</a>} [http::data $h]] {
  48. lappend z http://wiki.tcl.tk/$p\ \t$n
  49. if {$max == -1} { continue }
  50. if {[incr c] >= $max} { break }
  51. }
  52. }
  53. http::cleanup $h
  54. return $z
  55. }
  56.  
  57. proc herring::wikiref {msg} {
  58. global Options
  59.  
  60. if {[llength $msg] == 2} {
  61. set user [lindex $msg 0]
  62. set msg [lindex $msg 1]
  63. if {$user eq {me}} {
  64. set user $Options(Nickname)
  65. }
  66. } else {
  67. set user {}
  68. }
  69. set srchres [wikisearch $msg 10]
  70. if {[llength $srchres] > 0} {
  71. send [join $srchres \n] $user
  72. }
  73. }
  74.  
  75. proc herring::loadTwigs {{fn {}}} {
  76. variable cfg
  77.  
  78. if {$fn eq {}} {
  79. set fn $cfg(myTwigListFile)
  80. } elseif {$fn eq {?}} {
  81. set fn [tk_getOpenFile -defaultextension .twig -filetypes {{{TWiG Files} .twig} {{All Files} *}}]
  82. if {$fn eq {}} {
  83. return {}
  84. }
  85. }
  86.  
  87. set cfg(twigs) {}
  88.  
  89. set f [open $fn r]
  90. set cfg(twigs) [split [read -nonewline $f] \n]
  91. close $f
  92.  
  93. return "$fn loaded ok"
  94. }
  95.  
  96. proc herring::prettyTwigs {twigs {raw 0}} {
  97. if {[llength $twigs] == 0} {
  98. return {no twigs}
  99. }
  100.  
  101. set t {}
  102. set n 0
  103.  
  104. foreach l $twigs {
  105. if {$raw} {
  106. set l [linsert $l 0 [incr n].]
  107. } else {
  108. set l "[incr n]. [lindex $l 4]"
  109. }
  110. lappend t $l
  111. }
  112.  
  113. return [join $t \n]
  114. }
  115.  
  116. proc herring::twiggit {page {blocks 0}} {
  117. variable cfg
  118. return [exec $cfg(tclsh) $cfg(twig) $page $blocks]
  119. }
  120.  
  121. proc herring::runTwig {page {blocks 0} {name {}}} {
  122. variable cfg
  123. # exec $cfg(wish) <<[twiggit $page $blocks] &
  124. exec $cfg(tclsh) $cfg(twig) $page $blocks | $cfg(run) &
  125. }
  126.  
  127. proc herring::viewTwig {page {blocks 0} {name {}}} {
  128. view [twiggit $page $blocks] $name
  129. }
  130.  
  131. proc herring::twig {msg} {
  132. variable cfg
  133.  
  134. if {[catch {llength $msg}]} { return }
  135.  
  136. switch -exact -- [lindex $msg 0] {
  137. load {
  138. set fn {}
  139. set tag {}
  140. if {[llength $msg] == 2} { set fn [lindex $msg 1] }
  141. if {[catch {loadTwigs $fn} e]} { set tag ERROR }
  142. if {$e eq {}} { return }
  143. print $e $tag
  144. }
  145. list {
  146. set start 1
  147. set raw [expr {[lindex $msg $start] eq {-raw}}]
  148. if {$raw} { incr start }
  149. set user [lindex $msg $start]
  150. if {$user ne {}} {
  151. variable HookUserInfoDialog 1
  152. variable TwigInfoRaw $raw
  153. ::tkjabber::userinfo $user
  154. return
  155. }
  156. if {[llength $cfg(twigs)] == 0} {
  157. print {no twigs}
  158. return
  159. }
  160. print Loaded\ TWiGs:[expr {$raw?" (raw)":""}]\n[prettyTwigs $cfg(twigs) $raw]
  161. }
  162. view -
  163. run {
  164. if {[lindex $msg 0] eq {view}} {
  165. if {[llength $msg] == 1} {
  166. view
  167. } else {
  168. set tag {}
  169. if {[catch {viewFile [lindex $msg 1]} e]} { set tag ERROR }
  170. if {$e eq {}} { return }
  171. print $e $tag
  172. }
  173. return
  174. }
  175. if {[regexp {^(.+)\.$} [lindex $msg end] -> num]} {
  176. if {[llength $msg] > 2} {
  177. variable HookUserInfoDialog 1
  178. variable TwigRun $num
  179. ::tkjabber::userinfo [lindex $msg 1]
  180. return
  181. }
  182. if {[llength $cfg(twigs)] == 0} {
  183. print {no twigs}
  184. return
  185. }
  186. if {$num < 1 || $num >= [llength $cfg(twigs)]} {
  187. print {TWiG not found} ERROR
  188. return
  189. }
  190. incr num -1
  191. set twig [lindex $cfg(twigs) $num]
  192. set page [lindex $twig 0]
  193. set blocks [lindex $twig 1]
  194. set name [lindex $twig 4]
  195. } elseif {[llength $msg] > 1} {
  196. set page [lindex $msg 1]
  197. set blocks [lindex $msg 2]
  198. set name {}
  199. } else {
  200. print "run|view usage:\nrun|view ?user? #.\nrun|view page ?blocks?\nview" SYSTEM
  201. return
  202. }
  203. if {[catch [list [lindex $msg 0]Twig $page $blocks $name] e]} {
  204. print $e ERROR
  205. }
  206. }
  207. ? {
  208. set m {}
  209. lappend m "TWiG $cfg(version) Commands:"
  210. lappend m "list ?-raw? ?user?"
  211. lappend m "run|view ?user? #."
  212. lappend m "run|view page ?blocks?"
  213. lappend m "view ?filename?"
  214. lappend m "view ? (ask for file to view)"
  215. lappend m "view {} (view your .twig file)"
  216. lappend m "load ?filename?"
  217. print [join $m \n]
  218. }
  219. default {
  220. print "TWiG $cfg(version)\n/twig ? for help" SYSTEM
  221. }
  222. }
  223. }
  224.  
  225. proc herring::send {msg {user {me}}} {
  226. global Options
  227. variable floodcount
  228. variable floodmax
  229.  
  230. incr floodcount
  231.  
  232. if {$floodcount > $floodmax} {return}
  233.  
  234. if {$floodcount == $floodmax} {
  235. ::tkjabber::msgSend "/nolog stubot: outgoing msg count exceeded $floodmax msgs" -user $Options(Nickname) -attrs [list nolog 1]
  236. return
  237. }
  238.  
  239. if {[set c [string index $msg 0]] ne { } && $c ne {/}} {
  240. set msg " $msg"
  241. }
  242. if {$user eq {me}} {
  243. set user $Options(Nickname)
  244. }
  245.  
  246. set max 300
  247. if {[string length $msg] <= $max} {
  248. ::tkjabber::msgSend "/nolog$msg" -user $user -attrs [list nolog 1]
  249. } else {
  250. ::tkjabber::msgSend "/nolog stubot: outgoing msg exceeded $max chars" -user $Options(Nickname) -attrs [list nolog 1]
  251. }
  252. }
  253.  
  254. proc herring::print {msg {tag MSG}} {
  255. variable cfg
  256. global Options
  257.  
  258. if {$tag eq {}} {
  259. info default [lindex [info level 0] 0] tag tag
  260. }
  261.  
  262. $cfg(ctw) configure -state normal
  263.  
  264. set stuff [split $msg \n]
  265. $cfg(ctw) insert end TWiG\t[lindex $stuff 0]\n $tag
  266. foreach l [lrange $stuff 1 end] {
  267. $cfg(ctw) insert end \t$l\n $tag
  268. }
  269.  
  270. $cfg(ctw) configure -state disabled
  271. if {$Options(AutoScroll)} {
  272. $cfg(ctw) see end
  273. }
  274. }
  275.  
  276. proc herring::run {code} {
  277. variable cfg
  278. exec $cfg(run) <<$code &
  279. }
  280.  
  281. proc herring::save {what {name {}}} {
  282. if {$name eq {}} {
  283. set name [tk_getSaveFile]
  284. if {$name eq {}} {
  285. return
  286. }
  287. }
  288. if {[catch {
  289. set f [open $name w]
  290. puts -nonewline $f $what
  291. close $f
  292. } e]} {
  293. print $e ERROR
  294. } else {
  295. print "$name saved ok"
  296. }
  297. }
  298.  
  299. proc herring::viewFile {{fn {}}} {
  300. variable cfg
  301. if {$fn eq {}} {
  302. set fn $cfg(myTwigListFile)
  303. } elseif {$fn eq {?}} {
  304. set fn [tk_getOpenFile]
  305. if {$fn eq {}} {
  306. return {}
  307. }
  308. }
  309.  
  310. set f [open $fn r]
  311. set d [read -nonewline $f]
  312. close $f
  313.  
  314. view $d $fn
  315.  
  316. return {}
  317. }
  318.  
  319. proc herring::view {{what {}} {title {}}} {
  320. variable ::tkchat::NS
  321. catch {destroy .view}
  322. set dlg [::tkchat::Dialog .view]
  323. set w [${NS}::frame $dlg.f]
  324. wm withdraw $dlg
  325. wm title $dlg $title
  326. if {[llength [info command ::tkchat::img::Tkchat]] != 0} {
  327. catch {wm iconphoto $dlg ::tkchat::img::Tkchat}
  328. }
  329. ${NS}::button $w.b -text Dismiss -width -12 -command [list wm withdraw $dlg] -default active
  330. ::tkchat::ScrolledWidget text $w.text 0 1 -height 23 -width 80 \
  331. -borderwidth 0 -padx 2 -pady 2 -font FNT
  332. grid $w.text -sticky news
  333. ${NS}::button $w.bs -text Save -width -12 -command "::herring::save \[$w.text get 1.0 end\]" -default active
  334. ${NS}::button $w.br -text Run -width -12 -command "::herring::run \[$w.text get 1.0 end\]" -default active
  335. grid $w.bs -sticky se
  336. grid ^ $w.br -sticky se -padx 4
  337. grid ^ ^ $w.b -sticky se
  338. grid configure $w.text -columnspan 3
  339.  
  340. grid rowconfigure $w 0 -weight 1
  341. grid columnconfigure $w 0 -weight 1
  342.  
  343. $w.text insert end $what
  344.  
  345. grid $w -sticky news
  346. grid rowconfigure $dlg 0 -weight 1
  347. grid columnconfigure $dlg 0 -weight 1
  348.  
  349. # $w.text configure -state disabled
  350. # bind $dlg <Return> [list $w.b invoke]
  351. # bind $dlg <Escape> [list $w.b invoke]
  352. bind $dlg <Control-q> [list $w.b invoke]
  353. bind $dlg <Control-Q> [list $w.b invoke]
  354. catch {::tk::PlaceWindow $dlg widget .}
  355. wm deiconify $dlg
  356. # This was originally TkChat's [About]
  357. }
  358.  
  359.  
  360. # Here starts the evil section
  361.  
  362. proc herring::incomingUserInfo {jid desc} {
  363. variable TwigInfoRaw
  364. variable TwigRun
  365.  
  366. set delim {-*- TWiGs -*-}
  367. set delimmatch {-\*-*TWiGs*-\*-}
  368. set twigs {}
  369. set inTwigs 0
  370.  
  371. foreach l [split $desc \n] {
  372. set l [string trim $l]
  373. if {$inTwigs} {
  374. if {[string match -nocase $delimmatch $l]} {
  375. set inTwigs 0
  376. } else {
  377. if {![catch {llength $l} len] && $len == 5} {
  378. lappend twigs $l
  379. }
  380. }
  381. } elseif {[string match -nocase $delimmatch $l]} {
  382. set inTwigs 1
  383. }
  384. }
  385.  
  386. if {$TwigRun > 0} {
  387. set i $TwigRun
  388. set TwigRun 0
  389. if {$i < 1 || $i >= [llength $twigs]} {
  390. print No\ TWiGs\ for\ $jid
  391. return
  392. }
  393. incr i -1
  394. set twig [lindex $twigs $i]
  395. set page [lindex $twig 0]
  396. set blocks [lindex $twig 1]
  397. if {[catch {runTwig $page $blocks} e]} {
  398. send $e
  399. }
  400. } else {
  401. print TWiGs\ for\ $jid:\n[prettyTwigs $twigs $TwigInfoRaw]
  402. }
  403. }
  404.  
  405. proc herring::pimple {n1 n2 op} {
  406. uplevel 1 {trace remove variable UI(id) write ::herring::pimple}
  407. variable TwigInfo [uplevel 1 { set UI(DESC) }]
  408. rename ::tkchat::Dialog ::herring::_Dialog
  409. proc ::tkchat::Dialog {id} {
  410. rename ::tkchat::Dialog {}
  411. rename ::herring::_Dialog ::tkchat::Dialog
  412. ::tkchat::addStatus 0 "Getting [uplevel 1 { set jid }]'s TWiGs ..."
  413. after idle [list ::herring::incomingUserInfo [uplevel 1 { set jid }] [uplevel 1 { set UI(DESC) }]]
  414. uplevel 1 { unset -nocomplain [namespace current]::$id UI }
  415. uplevel 1 { return -level 2 }
  416. }
  417. }
  418.  
  419. proc ::herring::cow {n1 n2 op} {
  420. trace remove variable ::tkchat::UserInfoWin write ::herring::cow
  421. uplevel 1 {trace add variable UI(id) write ::herring::pimple}
  422. }
  423.  
  424.  
  425. if {[info command ::tkchat::_UserInfoDialog] eq {}} {
  426. rename ::tkchat::UserInfoDialog ::tkchat::_UserInfoDialog
  427. }
  428. proc ::tkchat::UserInfoDialog {{jid {}}} {
  429. # upvar #0 ::herring::HookUserInfoDialog HookUserInfoDialog
  430. variable ::herring::HookUserInfoDialog
  431.  
  432. if {!$HookUserInfoDialog} {
  433. ::tkchat::_UserInfoDialog $jid
  434. return
  435. }
  436.  
  437. set HookUserInfoDialog 0
  438.  
  439. trace remove variable ::tkchat::UserInfoWin write ::herring::cow
  440. variable UserInfoWin
  441. unset -nocomplain UserInfoWin
  442. trace add variable ::tkchat::UserInfoWin write ::herring::cow
  443.  
  444. ::tkchat::_UserInfoDialog $jid
  445.  
  446. trace remove variable ::tkchat::UserInfoWin write ::herring::cow
  447. }
  448.  
  449. # End of evil section
  450.  
  451.  
  452. proc ::herring::init {} {
  453. variable cfg
  454.  
  455.  
  456. foreach {alias proc} $cfg(aliasMap) {
  457. ::tkchat::processAliasCommand "/alias $alias proc $proc"
  458. }
  459. }
  460.  
  461. namespace eval herring {
  462. init
  463. }
  464.  
  465.  
  466. # EOF
  467.