Posted to tcl by hypnotoad at Wed Jun 09 11:21:11 GMT 2010view raw

  1. # By the overt act of typing this comment, the author of this code
  2. # releases it into the public domain. No claim of copyright is made.
  3. # In place of a legal notice, here is a blessing:
  4. #
  5. # May you do good and not evil.
  6. # May you find forgiveness for yourself and forgive others.
  7. # May you share freely, never taking more than you give.
  8. #
  9. #############################################################################
  10. #
  11. # This file contains code use to implement a simple command-line console
  12. # for Tcl/Tk.
  13. #
  14. package provide irm::console 0.2
  15. package require irm::main
  16. package require coregui
  17. # Create a console widget named $w. The prompt string is $prompt.
  18. # The title at the top of the window is $title
  19. #
  20. proc console:create {w prompt title} {
  21. upvar #0 $w.t v
  22. if {[winfo exists $w]} {destroy $w}
  23. if {[info exists v]} {unset v}
  24. toplevel $w
  25. wm title $w $title
  26. wm iconname $w $title
  27. ttk::frame $w.mb
  28. pack $w.mb -side top -fill x
  29. menubutton $w.mb.file -text File -menu $w.mb.file.m
  30. menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m
  31. menubutton $w.mb.tool -text Tools -menu $w.mb.tool.m
  32. pack $w.mb.file $w.mb.edit $w.mb.tool -side left -padx 8 -pady 1
  33. set m [menu $w.mb.file.m -tearoff 0]
  34. # $m add command -label {Source...} -command "console:SourceFile $w.t"
  35. # $m add command -label {Save As...} -command "console:SaveFile $w.t"
  36. # $m add separator
  37. $m add command -label {Close} -command "destroy $w"
  38. $m add command -label {Exit} -command exit
  39. set m [menu $w.mb.tool.m -tearoff 0]
  40. $m add command -label {SQLite Console} -command \
  41. {::sqlitecon::create .sqlitecon {sqlite> } {SQLite Console} db}
  42. $m add command -label {Proc Editor} -command \
  43. {package require irm::procedit; ::ped::create}
  44. console:create_child $w $prompt $w.mb.edit.m
  45. update
  46. }
  47.  
  48. # This routine creates a console as a child window within a larger
  49. # window. It also creates an edit menu named "$editmenu" if $editmenu!="".
  50. # The calling function is responsible for posting the edit menu.
  51. #
  52. proc console:create_child {w prompt editmenu} {
  53. upvar #0 $w.t v
  54. if {$editmenu!=""} {
  55. set m [menu $editmenu -tearoff 0]
  56. $m add command -label Cut -command "console:Cut $w.t"
  57. $m add command -label Copy -command "console:Copy $w.t"
  58. $m add command -label Paste -command "console:Paste $w.t"
  59. $m add command -label {Clear Screen} -command "console:Clear $w.t"
  60. $m add separator
  61. $m add command -label {Source...} -command "console:SourceFile $w.t"
  62. $m add command -label {Save As...} -command "console:SaveFile $w.t"
  63. catch {$editmenu config -postcommand "console:EnableEditMenu $w"}
  64. }
  65. ttk::scrollbar $w.sb -orient vertical -command "$w.t yview"
  66. pack $w.sb -side right -fill y
  67. text $w.t -font $::g(fixed-font) -yscrollcommand "$w.sb set"
  68. pack $w.t -side right -fill both -expand 1
  69. bindtags $w.t Console
  70. set v(editmenu) $editmenu
  71. set v(text) $w.t
  72. set v(history) 0
  73. set v(historycnt) 0
  74. set v(current) -1
  75. set v(prompt) $prompt
  76. set v(prior) {}
  77. set v(plength) [string length $v(prompt)]
  78. set v(x) 0
  79. set v(y) 0
  80. $w.t mark set insert end
  81. $w.t tag config ok -foreground blue
  82. $w.t tag config err -foreground red
  83. $w.t tag config grn -foreground #00a000
  84. $w.t tag config purple -foreground #c000c0
  85. $w.t tag config lblue -foreground #417a9b
  86. $w.t tag config orange -foreground #be9e4f
  87. $w.t insert end $v(prompt)
  88. $w.t mark set out 1.0
  89. catch {rename puts console:oldputs$w}
  90. proc puts args [format {
  91. if {![winfo exists %s]} {
  92. rename puts {}
  93. rename console:oldputs%s puts
  94. return [uplevel #0 puts $args]
  95. }
  96. switch -glob -- "[llength $args] $args" {
  97. {1 *} {
  98. set msg [lindex $args 0]\n
  99. set tag ok
  100. }
  101. {2 stdout *} {
  102. set msg [lindex $args 1]\n
  103. set tag ok
  104. }
  105. {2 stderr *} {
  106. set msg [lindex $args 1]\n
  107. set tag err
  108. }
  109. {2 green *} {
  110. set msg [lindex $args 1]\n
  111. set tag grn
  112. }
  113. {2 purple *} {
  114. set msg [lindex $args 1]\n
  115. set tag purple
  116. }
  117. {2 lightblue *} {
  118. set msg [lindex $args 1]\n
  119. set tag lblue
  120. }
  121. {2 orange *} {
  122. set msg [lindex $args 1]\n
  123. set tag orange
  124. }
  125. {2 -nonewline *} {
  126. set msg [lindex $args 1]
  127. set tag ok
  128. }
  129. {3 -nonewline stdout *} {
  130. set msg [lindex $args 2]
  131. set tag ok
  132. }
  133. {3 -nonewline stderr *} {
  134. set msg [lindex $args 2]
  135. set tag err
  136. }
  137. default {
  138. uplevel #0 console:oldputs%s $args
  139. return
  140. }
  141. }
  142. console:Puts %s $msg $tag
  143. } $w $w $w $w.t]
  144. after idle "focus $w.t"
  145. }
  146.  
  147. bind Console <1> {console:Button1 %W %x %y}
  148. bind Console <B1-Motion> {console:B1Motion %W %x %y}
  149. bind Console <B1-Leave> {console:B1Leave %W %x %y}
  150. bind Console <B1-Enter> {console:cancelMotor %W}
  151. bind Console <ButtonRelease-1> {console:cancelMotor %W}
  152. bind Console <KeyPress> {console:Insert %W %A}
  153. bind Console <Left> {console:Left %W}
  154. bind Console <Control-b> {console:Left %W}
  155. bind Console <Right> {console:Right %W}
  156. bind Console <Control-f> {console:Right %W}
  157. bind Console <BackSpace> {console:Backspace %W}
  158. bind Console <Control-h> {console:Backspace %W}
  159. bind Console <Delete> {console:Delete %W}
  160. bind Console <Control-d> {console:Delete %W}
  161. bind Console <Home> {console:Home %W}
  162. bind Console <Control-a> {console:Home %W}
  163. bind Console <End> {console:End %W}
  164. bind Console <Control-e> {console:End %W}
  165. bind Console <Return> {console:Enter %W}
  166. bind Console <KP_Enter> {console:Enter %W}
  167. bind Console <Up> {console:Prior %W}
  168. bind Console <Control-p> {console:Prior %W}
  169. bind Console <Down> {console:Next %W}
  170. bind Console <Control-n> {console:Next %W}
  171. bind Console <Control-k> {console:EraseEOL %W}
  172. bind Console <<Cut>> {console:Cut %W}
  173. bind Console <<Copy>> {console:Copy %W}
  174. bind Console <<Paste>> {console:Paste %W}
  175. bind Console <<Clear>> {console:Clear %W}
  176.  
  177. # Insert test at the "out" mark. The "out" mark is always
  178. # before the input line. New text appears on the line prior
  179. # to the current input line.
  180. #
  181. proc console:Puts {w t tag} {
  182. set nc [string length $t]
  183. set endc [string index $t [expr $nc-1]]
  184. if {$endc=="\n"} {
  185. if {[$w index out]<[$w index {insert linestart}]} {
  186. $w insert out [string range $t 0 [expr $nc-2]] $tag
  187. $w mark set out {out linestart +1 lines}
  188. } else {
  189. $w insert out $t $tag
  190. }
  191. } else {
  192. if {[$w index out]<[$w index {insert linestart}]} {
  193. $w insert out $t $tag
  194. } else {
  195. $w insert out $t\n $tag
  196. $w mark set out {out -1 char}
  197. }
  198. }
  199. $w yview insert
  200. }
  201.  
  202. # Insert a single character at the insertion cursor
  203. #
  204. proc console:Insert {w a} {
  205. $w insert insert $a
  206. $w yview insert
  207. }
  208.  
  209. # Move the cursor one character to the left
  210. #
  211. proc console:Left {w} {
  212. upvar #0 $w v
  213. scan [$w index insert] %d.%d row col
  214. if {$col>$v(plength)} {
  215. $w mark set insert "insert -1c"
  216. }
  217. }
  218.  
  219. # Erase the character to the left of the cursor
  220. #
  221. proc console:Backspace {w} {
  222. upvar #0 $w v
  223. scan [$w index insert] %d.%d row col
  224. if {$col>$v(plength)} {
  225. $w delete {insert -1c}
  226. }
  227. }
  228.  
  229. # Erase to the end of the line
  230. #
  231. proc console:EraseEOL {w} {
  232. upvar #0 $w v
  233. scan [$w index insert] %d.%d row col
  234. if {$col>=$v(plength)} {
  235. $w delete insert {insert lineend}
  236. }
  237. }
  238.  
  239. # Move the cursor one character to the right
  240. #
  241. proc console:Right {w} {
  242. $w mark set insert "insert +1c"
  243. }
  244.  
  245. # Erase the character to the right of the cursor
  246. #
  247. proc console:Delete w {
  248. $w delete insert
  249. }
  250.  
  251. # Move the cursor to the beginning of the current line
  252. #
  253. proc console:Home w {
  254. upvar #0 $w v
  255. scan [$w index insert] %d.%d row col
  256. $w mark set insert $row.$v(plength)
  257. }
  258.  
  259. # Move the cursor to the end of the current line
  260. #
  261. proc console:End w {
  262. $w mark set insert {insert lineend}
  263. }
  264.  
  265. # Called when "Enter" is pressed. Do something with the line
  266. # of text that was entered.
  267. #
  268. proc console:Enter w {
  269. upvar #0 $w v
  270. scan [$w index insert] %d.%d row col
  271. set start $row.$v(plength)
  272. set line [$w get $start "$start lineend"]
  273. if {$v(historycnt)>0} {
  274. set last [lindex $v(history) [expr $v(historycnt)-1]]
  275. if {[string compare $last $line]} {
  276. lappend v(history) $line
  277. incr v(historycnt)
  278. }
  279. } else {
  280. set v(history) [list $line]
  281. set v(historycnt) 1
  282. }
  283. set v(current) $v(historycnt)
  284. $w insert end \n
  285. $w mark set out end
  286. if {$v(prior)==""} {
  287. set cmd $line
  288. } else {
  289. set cmd $v(prior)\n$line
  290. }
  291. if {[info complete $cmd]} {
  292. set rc [catch {uplevel #0 $cmd} res]
  293. if {![winfo exists $w]} return
  294. if {$rc} {
  295. $w insert end $res\n err
  296. } elseif {[string length $res]>0} {
  297. $w insert end $res\n ok
  298. }
  299. set v(prior) {}
  300. $w insert end $v(prompt)
  301. } else {
  302. set v(prior) $cmd
  303. regsub -all {[^ ]} $v(prompt) . x
  304. $w insert end $x
  305. }
  306. $w mark set insert end
  307. $w mark set out {insert linestart}
  308. $w yview insert
  309. }
  310.  
  311. # Change the line to the previous line
  312. #
  313. proc console:Prior w {
  314. upvar #0 $w v
  315. if {$v(current)<=0} return
  316. incr v(current) -1
  317. set line [lindex $v(history) $v(current)]
  318. console:SetLine $w $line
  319. }
  320.  
  321. # Change the line to the next line
  322. #
  323. proc console:Next w {
  324. upvar #0 $w v
  325. if {$v(current)>=$v(historycnt)} return
  326. incr v(current) 1
  327. set line [lindex $v(history) $v(current)]
  328. console:SetLine $w $line
  329. }
  330.  
  331. # Change the contents of the entry line
  332. #
  333. proc console:SetLine {w line} {
  334. upvar #0 $w v
  335. scan [$w index insert] %d.%d row col
  336. set start $row.$v(plength)
  337. $w delete $start end
  338. $w insert end $line
  339. $w mark set insert end
  340. $w yview insert
  341. }
  342.  
  343. # Called when the mouse button is pressed at position $x,$y on
  344. # the console widget.
  345. #
  346. proc console:Button1 {w x y} {
  347. global tkPriv
  348. upvar #0 $w v
  349. set v(mouseMoved) 0
  350. set v(pressX) $x
  351. set p [console:nearestBoundry $w $x $y]
  352. scan [$w index insert] %d.%d ix iy
  353. scan $p %d.%d px py
  354. if {$px==$ix} {
  355. $w mark set insert $p
  356. }
  357. $w mark set anchor $p
  358. focus $w
  359. }
  360.  
  361. # Find the boundry between characters that is nearest
  362. # to $x,$y
  363. #
  364. proc console:nearestBoundry {w x y} {
  365. set p [$w index @$x,$y]
  366. set bb [$w bbox $p]
  367. if {![string compare $bb ""]} {return $p}
  368. if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}
  369. $w index "$p + 1 char"
  370. }
  371.  
  372. # This routine extends the selection to the point specified by $x,$y
  373. #
  374. proc console:SelectTo {w x y} {
  375. upvar #0 $w v
  376. set cur [console:nearestBoundry $w $x $y]
  377. if {[catch {$w index anchor}]} {
  378. $w mark set anchor $cur
  379. }
  380. set anchor [$w index anchor]
  381. if {[$w compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {
  382. if {$v(mouseMoved)==0} {
  383. $w tag remove sel 0.0 end
  384. }
  385. set v(mouseMoved) 1
  386. }
  387. if {[$w compare $cur < anchor]} {
  388. set first $cur
  389. set last anchor
  390. } else {
  391. set first anchor
  392. set last $cur
  393. }
  394. if {$v(mouseMoved)} {
  395. $w tag remove sel 0.0 $first
  396. $w tag add sel $first $last
  397. $w tag remove sel $last end
  398. update idletasks
  399. }
  400. }
  401.  
  402. # Called whenever the mouse moves while button-1 is held down.
  403. #
  404. proc console:B1Motion {w x y} {
  405. upvar #0 $w v
  406. set v(y) $y
  407. set v(x) $x
  408. console:SelectTo $w $x $y
  409. }
  410.  
  411. # Called whenever the mouse leaves the boundries of the widget
  412. # while button 1 is held down.
  413. #
  414. proc console:B1Leave {w x y} {
  415. upvar #0 $w v
  416. set v(y) $y
  417. set v(x) $x
  418. console:motor $w
  419. }
  420.  
  421. # This routine is called to automatically scroll the window when
  422. # the mouse drags offscreen.
  423. #
  424. proc console:motor w {
  425. upvar #0 $w v
  426. if {![winfo exists $w]} return
  427. if {$v(y)>=[winfo height $w]} {
  428. $w yview scroll 1 units
  429. } elseif {$v(y)<0} {
  430. $w yview scroll -1 units
  431. } else {
  432. return
  433. }
  434. console:SelectTo $w $v(x) $v(y)
  435. set v(timer) [after 50 console:motor $w]
  436. }
  437.  
  438. # This routine cancels the scrolling motor if it is active
  439. #
  440. proc console:cancelMotor w {
  441. upvar #0 $w v
  442. if [info exists v(timer)] {
  443. catch {after cancel $v(timer)}
  444. catch {unset -nocomplain v(timer)}
  445. }
  446. }
  447.  
  448. # Do a Copy operation on the stuff currently selected.
  449. #
  450. proc console:Copy w {
  451. if {![catch {set text [$w get sel.first sel.last]}]} {
  452. clipboard clear -displayof $w
  453. clipboard append -displayof $w $text
  454. }
  455. }
  456.  
  457. # Return 1 if the selection exists and is contained
  458. # entirely on the input line. Return 2 if the selection
  459. # exists but is not entirely on the input line. Return 0
  460. # if the selection does not exist.
  461. #
  462. proc console:canCut w {
  463. set r [catch {
  464. scan [$w index sel.first] %d.%d s1x s1y
  465. scan [$w index sel.last] %d.%d s2x s2y
  466. scan [$w index insert] %d.%d ix iy
  467. }]
  468. if {$r==1} {return 0}
  469. if {$s1x==$ix && $s2x==$ix} {return 1}
  470. return 2
  471. }
  472.  
  473. # Do a Cut operation if possible. Cuts are only allowed
  474. # if the current selection is entirely contained on the
  475. # current input line.
  476. #
  477. proc console:Cut w {
  478. if {[console:canCut $w]==1} {
  479. console:Copy $w
  480. $w delete sel.first sel.last
  481. }
  482. }
  483.  
  484. # Do a paste opeation.
  485. #
  486. proc console:Paste w {
  487. if {[console:canCut $w]==1} {
  488. $w delete sel.first sel.last
  489. }
  490. if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]} {
  491. return
  492. }
  493. set prior 0
  494. foreach line [split $topaste \n] {
  495. if {$prior} {
  496. console:Enter $w
  497. update
  498. }
  499. set prior 1
  500. $w insert insert $line
  501. }
  502. }
  503.  
  504. # Enable or disable entries in the Edit menu
  505. #
  506. proc console:EnableEditMenu w {
  507. upvar #0 $w.t v
  508. set m $v(editmenu)
  509. if {$m=="" || ![winfo exists $m]} return
  510. switch [console:canCut $w.t] {
  511. 0 {
  512. $m entryconf Copy -state disabled
  513. $m entryconf Cut -state disabled
  514. }
  515. 1 {
  516. $m entryconf Copy -state normal
  517. $m entryconf Cut -state normal
  518. }
  519. 2 {
  520. $m entryconf Copy -state normal
  521. $m entryconf Cut -state disabled
  522. }
  523. }
  524. }
  525.  
  526. # Prompt for the user to select an input file, the "source" that file.
  527. #
  528. proc console:SourceFile w {
  529. set types {
  530. {{TCL Scripts} {.tcl}}
  531. {{All Files} *}
  532. }
  533. set f [tk_getOpenFile -filetypes $types -title "TCL Script To Source..."]
  534. if {$f!=""} {
  535. uplevel #0 source $f
  536. }
  537. }
  538.  
  539. # Prompt the user for the name of a writable file. Then write the
  540. # entire contents of the console screen to that file.
  541. #
  542. proc console:SaveFile w {
  543. set types {
  544. {{Text Files} {.txt}}
  545. {{All Files} *}
  546. }
  547. set f [tk_getSaveFile -filetypes $types -title "Write Screen To..."]
  548. if {$f!=""} {
  549. if {[catch {open $f w} fd]} {
  550. tk_messageBox -type ok -icon error -message $fd
  551. } else {
  552. puts $fd [string trimright [$w get 1.0 end] \n]
  553. close $fd
  554. }
  555. }
  556. }
  557.  
  558. # Erase everything from the console above the insertion line.
  559. #
  560. proc console:Clear w {
  561. $w delete 1.0 {insert linestart}
  562. }
  563.  
  564. # Start the console
  565. #
  566. # console:create {.@console} {% } {Tcl/Tk Console}
  567.  
  568. # Bring up the console for MED debugging
  569. #
  570. proc console:start {} {
  571. if {[winfo exists .console]} {
  572. wm deiconify .console
  573. update
  574. raise .console
  575. } else {
  576. console:create .console {wish% } {Tcl/Tk Shell}
  577. }
  578. }