Posted to tcl by hypnotoad at Mon Jun 03 20:28:44 GMT 2019view raw

  1. package require clay 0.8
  2. package provide clay::tk::console 0.1
  3.  
  4. ###
  5. # topic: 3f0e8c2797e7bd5e470fce8f117980095ea094f0
  6. # description:
  7. # Open a console window for direct access to the
  8. # Tcl/Tk command interface to the IRM software suite
  9. ###
  10. proc ::console:start {} {
  11. if {[info command ::CONSOLE] ne {}} {
  12. CONSOLE wake
  13. } else {
  14. set args [list -prompt {wish% } -title {Tcl/Tk Shell}]
  15. ::clay::tk::console create CONSOLE .tclconsole mixinmap {language ::clay::tk::console.tcl} {*}$args
  16. }
  17. CONSOLE redirect_stdout
  18. }
  19.  
  20. # Create a console widget named $w. The prompt string is $prompt.
  21. # The title at the top of the window is $title. The database connection
  22. # object is $db
  23. #
  24. proc sqlitecon:create {w prompt title db} {
  25. if {[info commands ::clay::tk::$w] ne {}} {
  26. ::clay::tk::$w wake
  27. } else {
  28. set args [list prompt $prompt title $title db $db]
  29. destroy $w
  30. ::clay::tk::console create ::clay::tk::$w $w mixinmap {language ::clay::tk::console.sqlite} {*}$args
  31. }
  32. }
  33.  
  34. namespace eval ::clay::tk {}
  35.  
  36. ###
  37. # This file implements the clay event manager
  38. ###
  39. ::namespace eval ::clay::event {}
  40.  
  41. ###
  42. # topic: f2853d380a732845610e40375bcdbe0f
  43. # description: Cancel a scheduled event
  44. ###
  45. proc ::clay::event::cancel {self {task *}} {
  46. variable timer_event
  47. variable timer_script
  48.  
  49. foreach {id event} [array get timer_event $self:$task] {
  50. ::after cancel $event
  51. set timer_event($id) {}
  52. set timer_script($id) {}
  53. }
  54. }
  55.  
  56. ###
  57. # topic: 8ec32f6b6ba78eaf980524f8dec55b49
  58. # description:
  59. # Generate an event
  60. # Adds a subscription mechanism for objects
  61. # to see who has recieved this event and prevent
  62. # spamming or infinite recursion
  63. ###
  64. proc ::clay::event::generate {self event args} {
  65. set wholist [Notification_list $self $event]
  66. if {$wholist eq {}} return
  67. set dictargs [::oo::meta::args_to_options {*}$args]
  68. set info $dictargs
  69. set strict 0
  70. set debug 0
  71. set sender $self
  72. dict with dictargs {}
  73. dict set info id [::clay::event::nextid]
  74. dict set info origin $self
  75. dict set info sender $sender
  76. dict set info rcpt {}
  77. foreach who $wholist {
  78. catch {::clay::event::notify $who $self $event $info}
  79. }
  80. }
  81.  
  82. ###
  83. # topic: 891289a24b8cc52b6c228f6edb169959
  84. # title: Return a unique event handle
  85. ###
  86. proc ::clay::event::nextid {} {
  87. return "event#[format %0.8x [incr ::clay::event_count]]"
  88. }
  89.  
  90. ###
  91. # topic: 1e53e8405b4631aec17f98b3e8a5d6a4
  92. # description:
  93. # Called recursively to produce a list of
  94. # who recieves notifications
  95. ###
  96. proc ::clay::event::Notification_list {self event {stackvar {}}} {
  97. set notify_list {}
  98. foreach {obj patternlist} [array get ::clay::object_subscribe] {
  99. if {$obj eq $self} continue
  100. if {$obj in $notify_list} continue
  101. set match 0
  102. foreach {objpat eventlist} $patternlist {
  103. if {![string match $objpat $self]} continue
  104. foreach eventpat $eventlist {
  105. if {![string match $eventpat $event]} continue
  106. set match 1
  107. break
  108. }
  109. if {$match} {
  110. break
  111. }
  112. }
  113. if {$match} {
  114. lappend notify_list $obj
  115. }
  116. }
  117. return $notify_list
  118. }
  119.  
  120. ###
  121. # topic: b4b12f6aed69f74529be10966afd81da
  122. ###
  123. proc ::clay::event::notify {rcpt sender event eventinfo} {
  124. if {[info commands $rcpt] eq {}} return
  125. if {$::clay::trace} {
  126. puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  127. }
  128. $rcpt notify $event $sender $eventinfo
  129. }
  130.  
  131. ###
  132. # topic: 829c89bda736aed1c16bb0c570037088
  133. ###
  134. proc ::clay::event::process {self handle script} {
  135. variable timer_event
  136. variable timer_script
  137.  
  138. array unset timer_event $self:$handle
  139. array unset timer_script $self:$handle
  140.  
  141. set err [catch {uplevel #0 $script} result errdat]
  142. if $err {
  143. puts "BGError: $self $handle $script
  144. ERR: $result
  145. [dict get $errdat -errorinfo]
  146. ***"
  147. }
  148. }
  149.  
  150. ###
  151. # topic: eba686cffe18cd141ac9b4accfc634bb
  152. # description: Schedule an event to occur later
  153. ###
  154. proc ::clay::event::schedule {self handle interval script} {
  155. variable timer_event
  156. variable timer_script
  157. if {$::clay::trace} {
  158. puts [list $self schedule $handle $interval]
  159. }
  160. if {[info exists timer_event($self:$handle)]} {
  161. if {$script eq $timer_script($self:$handle)} {
  162. return
  163. }
  164. ::after cancel $timer_event($self:$handle)
  165. }
  166. set timer_script($self:$handle) $script
  167. set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]]
  168. }
  169.  
  170. ###
  171. # topic: e64cff024027ee93403edddd5dd9fdde
  172. ###
  173. proc ::clay::event::subscribe {self who event} {
  174. upvar #0 ::clay::object_subscribe($self) subscriptions
  175. if {![info exists subscriptions]} {
  176. set subscriptions {}
  177. }
  178. set match 0
  179. foreach {objpat eventlist} $subscriptions {
  180. if {![string match $objpat $who]} continue
  181. foreach eventpat $eventlist {
  182. if {[string match $eventpat $event]} {
  183. # This rule already exists
  184. return
  185. }
  186. }
  187. }
  188. dict lappend subscriptions $who $event
  189. }
  190.  
  191. ###
  192. # topic: 5f74cfd01735fb1a90705a5f74f6cd8f
  193. ###
  194. proc ::clay::event::unsubscribe {self args} {
  195. upvar #0 ::clay::object_subscribe($self) subscriptions
  196. if {![info exists subscriptions]} {
  197. return
  198. }
  199. switch [llength $args] {
  200. 1 {
  201. set event [lindex $args 0]
  202. if {$event eq "*"} {
  203. # Shortcut, if the
  204. set subscriptions {}
  205. } else {
  206. set newlist {}
  207. foreach {objpat eventlist} $subscriptions {
  208. foreach eventpat $eventlist {
  209. if {[string match $event $eventpat]} continue
  210. dict lappend newlist $objpat $eventpat
  211. }
  212. }
  213. set subscriptions $newlist
  214. }
  215. }
  216. 2 {
  217. set who [lindex $args 0]
  218. set event [lindex $args 1]
  219. if {$who eq "*" && $event eq "*"} {
  220. set subscriptions {}
  221. } else {
  222. set newlist {}
  223. foreach {objpat eventlist} $subscriptions {
  224. if {[string match $who $objpat]} {
  225. foreach eventpat $eventlist {
  226. if {[string match $event $eventpat]} continue
  227. dict lappend newlist $objpat $eventpat
  228. }
  229. }
  230. }
  231. set subscriptions $newlist
  232. }
  233. }
  234. }
  235. }
  236.  
  237.  
  238.  
  239.  
  240.  
  241. set ::clay::tk::winsys [tk windowingsystem]
  242. if {$::tcl_platform(platform) eq "windows"} {
  243. set ::clay::tk::platform windows
  244. catch {::ttk::style theme use xpnative}
  245. } else {
  246. if {$::tcl_platform(os) == "Darwin"} {
  247. set ::clay::tk::platform macosx
  248. } else {
  249. set ::clay::tk::platform unix
  250. }
  251. catch {::ttk::style theme use clam}
  252. }
  253.  
  254. ::clay::define ::clay::tk::megawidget {
  255.  
  256. constructor {tkpath args} {
  257. set hull $tkpath
  258. if {![winfo exists $tkpath]} {
  259. set toplevel $tkpath
  260. toplevel $tkpath
  261. } else {
  262. set toplevel [winfo toplevel $tkpath]
  263. destroy {*}[winfo children $tkpath]
  264. }
  265. my clay delegate hull $hull toplevel $toplevel
  266. my Config_merge $args
  267. my Hull_Populate
  268. my content
  269. }
  270.  
  271. destructor {
  272. my variable ismain
  273. if { $ismain } {
  274. catch {rename ::console:puts ::puts}
  275. }
  276. my Hull_Destroy
  277. }
  278.  
  279. Ensemble config::get args {
  280. return [my Config_get {*}$args]
  281. }
  282. Ensemble config::merge args {
  283. return [my Config_merge {*}$args]
  284. }
  285. Ensemble config::set args {
  286. my Config_set {*}$args
  287. }
  288.  
  289. method Config_get {field args} {
  290. my variable config option_canonical option_getcmd
  291. set field [string trimleft $field -]
  292. if {[info exists option_canonical($field)]} {
  293. set field $option_canonical($field)
  294. }
  295. if {[info exists option_getcmd($field)]} {
  296. return [eval $option_getcmd($field)]
  297. }
  298. if {[dict exists $config $field]} {
  299. return [dict get $config $field]
  300. }
  301. if {[llength $args]} {
  302. return [lindex $args 0]
  303. }
  304. return [my meta cget $field]
  305. }
  306.  
  307. ###
  308. # topic: dc9fba12ec23a3ad000c66aea17135a5
  309. ###
  310. method Config_merge dictargs {
  311. my variable config option_canonical
  312. set rawlist $dictargs
  313. set dictargs {}
  314. set dat [my clay get option]
  315. foreach {field val} $rawlist {
  316. set field [string trim $field -:/]
  317. if {[info exists option_canonical($field)]} {
  318. set field $option_canonical($field)
  319. }
  320. if {$field eq "mixinmap"} {
  321. my clay mixinmap {*}$val
  322. } elseif {$field eq "delegate"} {
  323. my clay delegate {*}$val
  324. } else {
  325. dict set dictargs $field $val
  326. }
  327. }
  328. ###
  329. # Validate all inputs
  330. ###
  331. foreach {field val} $dictargs {
  332. set script [my clay get option $field validate-command]
  333. if {$script ne {}} {
  334. dict set dictargs $field [eval [string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]]
  335. }
  336. }
  337. ###
  338. # Apply all inputs with special rules
  339. ###
  340. foreach {field val} $dictargs {
  341. set script [my clay get option $field set-command]
  342. dict set config $field $val
  343. if {$script ne {}} {
  344. {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
  345. }
  346. }
  347. return $dictargs
  348. }
  349.  
  350. method Config_set args {
  351. set dictargs [::clay::args_to_options {*}$args]
  352. set dat [my Config_merge $dictargs]
  353. my Config_triggers $dat
  354. }
  355.  
  356. ###
  357. # topic: 543c936485189593f0b9ed79b5d5f2c0
  358. ###
  359. method Config_triggers dictargs {
  360. foreach {field val} $dictargs {
  361. set script [my clay get option $field post-command]
  362. if {$script ne {}} {
  363. {*}[string map [list %field% [list $field] %value% [list $val] %self% [namespace which my]] $script]
  364. }
  365. }
  366. }
  367.  
  368. method content {} {}
  369.  
  370. method event {submethod args} {
  371. ::clay::event::$submethod [self] {*}$args
  372. }
  373.  
  374. method Option_Default field {
  375. set info [my meta getnull option $field]
  376. set getcmd [dict getnull $info default-command:]
  377. if {$getcmd ne {}} {
  378. return [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
  379. } else {
  380. return [dict getnull $info default:]
  381. }
  382. }
  383.  
  384. method Hull_Bind tkpath {
  385. bind $tkpath <Destroy> [namespace code {my Hull_Destroy_From_Tk %w}]
  386. }
  387.  
  388. method Hull_Destroy {} {
  389. set w [my widget hull]
  390. if {![winfo exists $w]} return
  391. bind $w <Destroy> {}
  392. $w destroy
  393. }
  394.  
  395. method Hull_Destroy_From_Tk {tkpath} {
  396. set w [my widget hull]
  397. if { [string match "${tkpath}*" $w] } {
  398. bind $w <Destroy> {}
  399. my destroy
  400. }
  401. }
  402.  
  403. method signal args {}
  404.  
  405. # Renames the tcl command that represents the widget to
  406. # one that resides in the object's namespace. It then renames
  407. # the object to catch calls to the tk path.
  408. ###
  409. method tkalias tkname {
  410. set oldname $tkname
  411. my variable tkalias
  412. set tkalias $tkname
  413. set self [self]
  414. set hullwidget [::info object namespace $self]::tkwidget
  415. my clay delegate tkwidget $hullwidget
  416. rename ::$tkalias $hullwidget
  417. my clay delegate hullwidget $hullwidget
  418. ::clay::object_rename [self] ::$tkalias
  419. my Hull_Bind $tkname
  420. return $hullwidget
  421. }
  422.  
  423. method wake {} {
  424. set hull [my clay delegate hull]
  425. if {![winfo exists $hull]} {
  426. my clay delegate toplevel $hull
  427. toplevel $hull
  428. my Hull_Populate
  429. } else {
  430. catch [list wm deiconify [my widget toplevel]]
  431. update
  432. catch [list raise [my widget toplevel]]
  433. catch [list focus [my widget hull]]
  434. }
  435. }
  436. }
  437.  
  438. ###
  439. # topic: fc7ea2899bddf6a00d04dc7515fd004702d282ef
  440. # description:
  441. # By the overt act of typing this comment, the author of this code
  442. # releases it into the public domain. No claim of copyright is made.
  443. # In place of a legal notice, here is a blessing:
  444. #
  445. # May you do good and not evil.
  446. # May you find forgiveness for yourself and forgive others.
  447. # May you share freely, never taking more than you give.
  448. #
  449. #
  450. #
  451. # This file contains code use to implement a simple command-line console
  452. # for Tcl/Tk.
  453. ###
  454.  
  455. ::clay::define ::clay::tk::console {
  456. superclass megawidget
  457. Variable toplevel {}
  458. Variable ismain 0
  459. clay set option language {
  460. default tcl
  461. }
  462. clay set option title {
  463. default {}
  464. }
  465. clay set option prompt {
  466. default {tcl% }
  467. }
  468. set has_consolas [expr {"Consolas" in [font families]}]
  469. if {$has_consolas} {
  470. set font {Consolas 10}
  471. switch $::clay::tk::platform {
  472. macosx {
  473. set font {Consolas 12}
  474. }
  475. }
  476. } else {
  477. set font {fixed 10}
  478. switch $::clay::tk::platform {
  479. macosx {
  480. set font {system 10}
  481. }
  482. windows {
  483. set font {systemfixed 9}
  484. }
  485. }
  486. }
  487. clay set option font [list \
  488. widget font \
  489. description {Font used on console widgets} \
  490. default $font ]
  491.  
  492. clay set signal focus {
  493. follows *
  494. action {focus [my clay delegate text]}
  495. }
  496.  
  497.  
  498. destructor {
  499. my variable ismain
  500. if { $ismain } {
  501. catch {rename ::console:puts ::puts}
  502. }
  503. my Hull_Destroy
  504.  
  505. set terminate [expr {$hull eq "."}]
  506. if {$terminate} {
  507. exit 0
  508. }
  509. }
  510.  
  511.  
  512. ###
  513. # topic: 03ca79afffe63938a00a9bd124316ba6fe83443d
  514. ###
  515. method addHistory line {
  516. my variable v
  517. if {$v(historycnt)>0} {
  518. set last [lindex $v(history) [expr $v(historycnt)-1]]
  519. if {[string compare $last $line]} {
  520. lappend v(history) $line
  521. incr v(historycnt)
  522. }
  523. } else {
  524. set v(history) [list $line]
  525. set v(historycnt) 1
  526. }
  527. set v(current) $v(historycnt)
  528. }
  529.  
  530. ###
  531. # topic: 83fc9e18be0f0d1798c7e20e7ccb23d806e1474c
  532. # description:
  533. # Called whenever the mouse leaves the boundries of the widget
  534. # while button 1 is held down.
  535. ###
  536. method B1Leave {x y} {
  537. my variable v
  538. set v(y) $y
  539. set v(x) $x
  540. my motor
  541. }
  542.  
  543. ###
  544. # topic: 61622cb601a30cc516a5b227c37e80444ae09911
  545. # description: Called whenever the mouse moves while button-1 is held down.
  546. ###
  547. method B1Motion {x y} {
  548. my variable v
  549. set v(y) $y
  550. set v(x) $x
  551. my SelectTo $x $y
  552. }
  553.  
  554. ###
  555. # topic: b8eb39886df4395c26e911532af6c904910c735d
  556. # description: Erase the character to the left of the cursor
  557. ###
  558. method Backspace {} {
  559. my variable v
  560. scan [my <text> index insert] %d.%d row col
  561. if {$col>$v(plength)} {
  562. my <text> delete {insert -1c}
  563. }
  564. }
  565.  
  566. ###
  567. # topic: 055c60d0743072b8d18f23322164664b80fa9328
  568. ###
  569. method build_buttons {} {
  570. my variable v
  571. set mb [my widget subwindow mb]
  572. ttk::frame $mb
  573. my clay delegate buttonframe $mb
  574. pack $mb -side top -fill x
  575. menubutton $mb.file -text File -menu $mb.file.m
  576. menubutton $mb.edit -text Edit -menu $mb.edit.m
  577. menubutton $mb.tool -text Tools -menu $mb.tool.m
  578. pack $mb.file $mb.edit $mb.tool -side left -padx 8 -pady 1
  579. set m [menu $mb.file.m -tearoff 0]
  580. # $m add command -label {Source...} -command "console:SourceFile $w.t"
  581. # $m add command -label {Save As...} -command "console:SaveFile $w.t"
  582. # $m add separator
  583. $m add command -label {Close} -command [list destroy [my widget hull]]
  584. $m add command -label {Exit} -command exit
  585. #$m add command -label {SQLite Console} -command \
  586. # {::sqlitecon::create .sqlitecon {sqlite> } {SQLite Console} db}
  587.  
  588. set m [menu $mb.tool.m -tearoff 0]
  589.  
  590. set editmenu $mb.edit.m
  591. set v(editmenu) $editmenu
  592. set m [menu $editmenu -tearoff 0]
  593. $m add command -label Cut -command [namespace code "my Cut"]
  594. $m add command -label Copy -command [namespace code "my Copy"]
  595. $m add command -label Paste -command [namespace code "my Paste"]
  596. $m add command -label {Clear Screen} -command [namespace code "my Clear"]
  597. $m add separator
  598. $m add command -label {Source...} -command [namespace code "my SourceFile"]
  599. $m add command -label {Save As...} -command [namespace code "my SaveFile"]
  600. catch {$editmenu config -postcommand [namespace code "my EnableEditMenu"]}
  601. }
  602.  
  603. method SBSET {args} {
  604. set sb [my widget subwindow sb]
  605. catch {$sb set {*}$args}
  606. }
  607.  
  608. ###
  609. # topic: 93a511dc8939a3f59315d2b2016946e82cc4c12c
  610. ###
  611. method build_console {} {
  612. set w [my widget hull]
  613. my variable v
  614. array set v {
  615. pressX 0
  616. mouseMoved 0
  617. }
  618. set sb [my widget subwindow sb]
  619. set st [my widget subwindow console]
  620. ttk::scrollbar $sb -orient vertical -command "$st yview"
  621. pack $sb -side right -fill y
  622. text $st -font [my Config_get font] -yscrollcommand [namespace code {my SBSET}]
  623. pack $st -side right -fill both -expand 1
  624.  
  625. my clay delegate text $st
  626. set prompt [my Config_get prompt]
  627.  
  628. set v(text) $st
  629. set v(history) 0
  630. set v(historycnt) 0
  631. set v(current) -1
  632. set v(prompt) $prompt
  633. set v(prior) {}
  634. set v(plength) [string length $v(prompt)]
  635. set v(x) 0
  636. set v(y) 0
  637. $st mark set insert end
  638. $st tag config ok -foreground blue
  639. $st tag config err -foreground red
  640. $st tag config grn -foreground #00a000
  641. $st tag config purple -foreground #c000c0
  642. $st tag config lblue -foreground #417a9b
  643. $st tag config orange -foreground #be9e4f
  644. $st insert end $v(prompt)
  645. $st mark set out 1.0
  646.  
  647. my signal focus
  648. bindtags $st [list $st . all]
  649.  
  650. bind $st <1> [namespace code {my Button1 %x %y}]
  651. bind $st <B1-Motion> [namespace code {my B1Motion %x %y}]
  652. bind $st <B1-Leave> [namespace code {my B1Leave %x %y}]
  653. bind $st <B1-Enter> [namespace code {my cancelMotor}]
  654. bind $st <ButtonRelease-1> [namespace code {my cancelMotor}]
  655. bind $st <KeyPress> [namespace code {my Insert %A}]
  656. bind $st <Left> [namespace code {my Left}]
  657. bind $st <Control-b> [namespace code {my Left}]
  658. bind $st <Right> [namespace code {my Right}]
  659. bind $st <Control-f> [namespace code {my Right}]
  660. bind $st <BackSpace> [namespace code {my Backspace}]
  661. bind $st <Control-h> [namespace code {my Backspace}]
  662. bind $st <Delete> [namespace code {my Delete}]
  663. bind $st <Control-d> [namespace code {my Delete}]
  664. bind $st <Home> [namespace code {my Home}]
  665. bind $st <Control-a> [namespace code {my Home}]
  666. bind $st <End> [namespace code {my End}]
  667. bind $st <Control-e> [namespace code {my End}]
  668. bind $st <Return> [namespace code {my Enter}]
  669. bind $st <KP_Enter> [namespace code {my Enter}]
  670. bind $st <Up> [namespace code {my Prior}]
  671. bind $st <Control-p> [namespace code {my Prior}]
  672. bind $st <Down> [namespace code {my Next}]
  673. bind $st <Control-n> [namespace code {my Next}]
  674. bind $st <Control-k> [namespace code {my EraseEOL}]
  675. bind $st <<Cut>> [namespace code {my Cut}]
  676. bind $st <<Copy>> [namespace code {my Copy}]
  677. bind $st <<Paste>> [namespace code {my Paste}]
  678. bind $st <<Clear>> [namespace code {my Clear}]
  679. }
  680.  
  681. ###
  682. # topic: 67ea0661809dd66ff34b45263c465789bfbb9591
  683. # description:
  684. # Called when the mouse button is pressed at position $x,$y on
  685. # the console widget.
  686. ###
  687. method Button1 {x y} {
  688. global tkPriv
  689. set w [my clay delegate text]
  690. my variable v
  691. set v(mouseMoved) 0
  692. set v(pressX) $x
  693. set p [my nearestBoundry $x $y]
  694. scan [my <text> index insert] %d.%d ix iy
  695. scan $p %d.%d px py
  696. if {$px==$ix} {
  697. my <text> mark set insert $p
  698. }
  699. my <text> mark set anchor $p
  700. focus $w
  701. }
  702.  
  703. ###
  704. # topic: 937a1570589f78997120e0f82d9989651a462dad
  705. # description: This routine cancels the scrolling motor if it is active
  706. ###
  707. method cancelMotor {} {
  708. my event cancel motor
  709. }
  710.  
  711. ###
  712. # topic: 968b14fc7c6cbd13fd8a23f3d635ae0da45c6561
  713. # description:
  714. # Return 1 if the selection exists and is contained
  715. # entirely on the input line. Return 2 if the selection
  716. # exists but is not entirely on the input line. Return 0
  717. # if the selection does not exist.
  718. ###
  719. method canCut {} {
  720. set r [catch {
  721. scan [my <text> index sel.first] %d.%d s1x s1y
  722. scan [my <text> index sel.last] %d.%d s2x s2y
  723. scan [my <text> index insert] %d.%d ix iy
  724. }]
  725. if {$r==1} {return 0}
  726. if {$s1x==$ix && $s2x==$ix} {return 1}
  727. return 2
  728. }
  729.  
  730. ###
  731. # topic: 4a6b17559391aff67a3b8d9e850da371c89ff5ab
  732. # description: Erase everything from the console above the insertion line.
  733. ###
  734. method Clear {} {
  735. my <text> delete 1.0 {insert linestart}
  736. }
  737.  
  738. ###
  739. # topic: cca0174bee56d0c82519a22c26fa417a3d61e373
  740. # description: Do a Copy operation on the stuff currently selected.
  741. ###
  742. method Copy {} {
  743. set w [my clay delegate text]
  744. if {![catch {set text [my <text> get sel.first sel.last]}]} {
  745. clipboard clear -displayof $w
  746. clipboard append -displayof $w $text
  747. }
  748. }
  749.  
  750. ###
  751. # topic: 5600bf5544e3c2a4c7d5b2a8a8f77e3cf4fb80f1
  752. # description:
  753. # Do a Cut operation if possible. Cuts are only allowed
  754. # if the current selection is entirely contained on the
  755. # current input line.
  756. ###
  757. method Cut {} {
  758. if {[my canCut]==1} {
  759. my Copy
  760. my <text> delete sel.first sel.last
  761. }
  762. }
  763.  
  764. ###
  765. # topic: 340c92b30cf1d0ee90eac3cc9ee0ff99360bb42d
  766. # description: Erase the character to the right of the cursor
  767. ###
  768. method Delete {} {
  769. my <text> delete insert
  770. }
  771.  
  772. ###
  773. # topic: a11cb7a2a3118e0f46a332542e4853543f18cf8b
  774. ###
  775. method dialog_preferences {} {
  776. set pvar [my varname prefs]
  777. set f [my widget hull]
  778. if {[winfo exists $f.prefs]} {
  779. destroy {*}[winfo children $f.prefs]
  780. wm deiconify $f.prefs
  781. raise $f.prefs
  782. $f.prefs signal build_content
  783. } else {
  784. ::clay::tk::preference_panel $f.prefs object [self]
  785. }
  786. }
  787.  
  788.  
  789.  
  790. ###
  791. # topic: 0c0ea9da28a51f2440c58c80021e67e605d750db
  792. # description: Enable or disable entries in the Edit menu
  793. ###
  794. method EnableEditMenu {} {
  795. my variable v
  796. set m $v(editmenu)
  797. if {$m=="" || ![winfo exists $m]} return
  798. switch [my canCut] {
  799. 0 {
  800. $m entryconf Copy -state disabled
  801. $m entryconf Cut -state disabled
  802. }
  803. 1 {
  804. $m entryconf Copy -state normal
  805. $m entryconf Cut -state normal
  806. }
  807. 2 {
  808. $m entryconf Copy -state normal
  809. $m entryconf Cut -state disabled
  810. }
  811. }
  812. }
  813.  
  814. ###
  815. # topic: b6157a20658fef4530840f60f8163984a8c0bd6b
  816. # description: Move the cursor to the end of the current line
  817. ###
  818. method End {} {
  819. my <text> mark set insert {insert lineend}
  820. }
  821.  
  822. ###
  823. # topic: ade17f15ff8a2b984f503c9570066952844ddf4e
  824. # description: Erase to the end of the line
  825. ###
  826. method EraseEOL {} {
  827. my variable v
  828. scan [my <text> index insert] %d.%d row col
  829. if {$col>=$v(plength)} {
  830. my <text> delete insert {insert lineend}
  831. }
  832. }
  833.  
  834. ###
  835. # topic: ab0549c4965bf2dabdd74d318531a3a2bc90cf85
  836. # description: Move the cursor to the beginning of the current line
  837. ###
  838. method Home {} {
  839. my variable v
  840. scan [my <text> index insert] %d.%d row col
  841. my <text> mark set insert $row.$v(plength)
  842. }
  843.  
  844. ###
  845. # topic: 04d56668301bb768d53522d5754828bf8b8e2cfa
  846. ###
  847. method Hull_Populate {} {
  848. set t [my widget toplevel]
  849. set w [my widget hull]
  850. set prompt [my Config_get prompt]
  851. set title [my Config_get title]
  852. upvar #0 $w.t v
  853. if {[info exists v]} {unset v}
  854. wm title $w $title
  855. wm iconname $w $title
  856. my clay delegate hull $t
  857.  
  858. my build_buttons
  859. my build_console
  860. }
  861.  
  862. ###
  863. # topic: f21c52fa306df0b911649a088f634792260f9bc3
  864. # description: Insert a single character at the insertion cursor
  865. ###
  866. method Insert a {
  867. my <text> insert insert $a
  868. my <text> yview insert
  869. }
  870.  
  871. ###
  872. # topic: a86a704912089f9f69a51608a795ca78846e1c59
  873. ###
  874. method insert text {
  875. my insert $a
  876. my Enter
  877. }
  878.  
  879. ###
  880. # topic: a893a71497eca915ca47f88a86f296a05ce1fcab
  881. # description: Move the cursor one character to the left
  882. ###
  883. method Left {} {
  884. my variable v
  885. scan [my <text> index insert] %d.%d row col
  886. if {$col>$v(plength)} {
  887. my <text> mark set insert "insert -1c"
  888. }
  889. }
  890.  
  891. ###
  892. # topic: f7d39c17edaa0287b478e6e9924e1ad6c5376ddc
  893. # description:
  894. # This routine is called to automatically scroll the window when
  895. # the mouse drags offscreen.
  896. ###
  897. method motor {} {
  898. my variable v
  899. set w [my clay delegate text]
  900. if {![winfo exists $w]} return
  901. if {$v(y)>=[winfo height $w]} {
  902. $w yview scroll 1 units
  903. } elseif {$v(y)<0} {
  904. $w yview scroll -1 units
  905. } else {
  906. return
  907. }
  908. my SelectTo $v(x) $v(y)
  909. my event schedule motor 50 [namespace code {my motor}]
  910. }
  911.  
  912. ###
  913. # topic: 9089b1e19d4d54d37830de5832c94ed317abfc54
  914. # description:
  915. # Find the boundry between characters that is nearest
  916. # to $x,$y
  917. ###
  918. method nearestBoundry {x y} {
  919. my variable v
  920. set p [my <text> index @$x,$y]
  921. set bb [my <text> bbox $p]
  922. if {![string compare $bb ""]} {return $p}
  923. if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}
  924. my <text> index "$p + 1 char"
  925. }
  926.  
  927. ###
  928. # topic: f2543342648de822341ab839b19fc875549c0d71
  929. # description: Change the line to the next line
  930. ###
  931. method Next {} {
  932. my variable v
  933. if {$v(current)>=$v(historycnt)} return
  934. incr v(current) 1
  935. set line [lindex $v(history) $v(current)]
  936. my SetLine $line
  937. }
  938.  
  939. ###
  940. # topic: 1fbaa6cd76c0ba81725f87e67e30c28f13a42de4
  941. ###
  942. method Option_set::font newvalue {
  943. my <text> configure -font $newvalue
  944. }
  945.  
  946. ###
  947. # topic: c2f59206f13fc6cd17ba0cc916d4b64853545642
  948. # description: Do a paste opeation.
  949. ###
  950. method Paste {} {
  951. my variable v
  952. if {[my canCut]==1} {
  953. my <text> delete sel.first sel.last
  954. }
  955. set w [my clay delegate text]
  956. if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]
  957. && [catch {selection get -displayof $w -selection PRIMARY} topaste]} {
  958. return
  959. }
  960. set prior 0
  961. foreach line [split $topaste \n] {
  962. if {$prior} {
  963. my Enter
  964. update
  965. }
  966. set prior 1
  967. my <text> insert insert $line
  968. }
  969. }
  970.  
  971. ###
  972. # topic: 1bdd01f30493ccdf242fcb581c188a861bc51246
  973. # description: Change the line to the previous line
  974. ###
  975. method Prior {} {
  976. my variable v
  977. if {$v(current)<=0} return
  978. incr v(current) -1
  979. set line [lindex $v(history) $v(current)]
  980. my SetLine $line
  981. }
  982.  
  983. ###
  984. # topic: f58b9ac700bd1dc6748c89a4d346e7cc4a068bf6
  985. # description:
  986. # Insert test at the "out" mark. The "out" mark is always
  987. # before the input line. New text appears on the line prior
  988. # to the current input line.
  989. ###
  990. method puts {t tag} {
  991. set nc [string length $t]
  992. set endc [string index $t [expr $nc-1]]
  993. if {$endc=="\n"} {
  994. if {[my <text> index out]<[my <text> index {insert linestart}]} {
  995. my <text> insert out [string range $t 0 [expr $nc-2]] $tag
  996. my <text> mark set out {out linestart +1 lines}
  997. } else {
  998. my <text> insert out $t $tag
  999. }
  1000. } else {
  1001. if {[my <text> index out]<[my <text> index {insert linestart}]} {
  1002. my <text> insert out $t $tag
  1003. } else {
  1004. my <text> insert out $t\n $tag
  1005. my <text> mark set out {out -1 char}
  1006. }
  1007. }
  1008. my <text> yview insert
  1009. }
  1010.  
  1011. ###
  1012. # topic: c7a8603d316f43da21effe7223902dd2853ded43
  1013. # description: Move the cursor one character to the right
  1014. ###
  1015. method Right {} {
  1016. my <text> mark set insert "insert +1c"
  1017. }
  1018.  
  1019. ###
  1020. # topic: 0833547d2ad5522b8a54fa0d92d339e4197ab635
  1021. # description:
  1022. # Prompt the user for the name of a writable file. Then write the
  1023. # entire contents of the console screen to that file.
  1024. ###
  1025. method SaveFile {} {
  1026. set types {
  1027. {{Text Files} {.txt}}
  1028. {{All Files} *}
  1029. }
  1030. set f [tk_getSaveFile -filetypes $types -title "Write Screen To..."]
  1031. if {$f!=""} {
  1032. if {[catch {open $f w} fd]} {
  1033. ::clay::tk::dialog -type ok -icon error -message {Error writing file} -detail $fd
  1034. } else {
  1035. puts $fd [string trimright [my <text> get 1.0 end] \n]
  1036. close $fd
  1037. }
  1038. }
  1039. }
  1040.  
  1041. ###
  1042. # topic: 71af63e2fb369f7677c165caa724b99b2ac0ca26
  1043. # description: This routine extends the selection to the point specified by {$x,$y}
  1044. ###
  1045. method SelectTo {x y} {
  1046. my variable v
  1047. set cur [my nearestBoundry $x $y]
  1048. if {[catch {my <text> index anchor}]} {
  1049. my <text> mark set anchor $cur
  1050. }
  1051. set anchor [my <text> index anchor]
  1052. if {[my <text> compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {
  1053. if {$v(mouseMoved)==0} {
  1054. my <text> tag remove sel 0.0 end
  1055. }
  1056. set v(mouseMoved) 1
  1057. }
  1058. if {[my <text> compare $cur < anchor]} {
  1059. set first $cur
  1060. set last anchor
  1061. } else {
  1062. set first anchor
  1063. set last $cur
  1064. }
  1065. if {$v(mouseMoved)} {
  1066. my <text> tag remove sel 0.0 $first
  1067. my <text> tag add sel $first $last
  1068. my <text> tag remove sel $last end
  1069. update idletasks
  1070. }
  1071. }
  1072.  
  1073. ###
  1074. # topic: d832f029f5a3c95ebbbc0c7f46b053151dbecd2e
  1075. # description: Change the contents of the entry line
  1076. ###
  1077. method SetLine line {
  1078. my variable v
  1079. scan [my <text> index insert] %d.%d row col
  1080. set start $row.$v(plength)
  1081. my <text> delete $start end
  1082. my <text> insert end $line
  1083. my <text> mark set insert end
  1084. my <text> yview insert
  1085. }
  1086.  
  1087. Ensemble widget::toplevel {} {
  1088. return [my clay delegate toplevel]
  1089. }
  1090. Ensemble widget::hull {} {
  1091. return [my clay delegate hull]
  1092. }
  1093. Ensemble widget::parent {} {
  1094. return [winfo parent [my clay delegate hull]]
  1095. }
  1096. Ensemble widget::subwindow path {
  1097. set tl [string trimleft [my widget hull] .]
  1098. if { $tl eq {} } {
  1099. return .[string trimleft $path .]
  1100. }
  1101. return .$tl.[string trimleft $path .]
  1102. }
  1103. }
  1104.  
  1105. ::clay::define ::clay::tk::console.tcl {
  1106. ###
  1107. # topic: c3d3bed792724df80d4ee0a5b1bc486d2501fd69
  1108. # description:
  1109. # Called when "Enter" is pressed. Do something with the line
  1110. # of text that was entered.
  1111. ###
  1112. method Enter {} {
  1113. my variable v
  1114. set w [my clay delegate text]
  1115. scan [my <text> index insert] %d.%d row col
  1116. set start $row.$v(plength)
  1117. set line [my <text> get $start "$start lineend"]
  1118. my addHistory $line
  1119. my <text> insert end \n
  1120. my <text> mark set out end
  1121. if {$v(prior)==""} {
  1122. set cmd $line
  1123. } else {
  1124. set cmd $v(prior)\n$line
  1125. }
  1126. if {[info complete $cmd]} {
  1127. set rc [catch {uplevel #0 $cmd} res]
  1128. if {![winfo exists $w]} return
  1129. if {$rc} {
  1130. my <text> insert end $res\n err
  1131. } elseif {[string length $res]>0} {
  1132. my <text> insert end $res\n ok
  1133. }
  1134. set v(prior) {}
  1135. my <text> insert end $v(prompt)
  1136. } else {
  1137. set v(prior) $cmd
  1138. regsub -all {[^ ]} $v(prompt) . x
  1139. my <text> insert end $x
  1140. }
  1141. my <text> mark set insert end
  1142. my <text> mark set out {insert linestart}
  1143. my <text> yview insert
  1144. }
  1145.  
  1146. ###
  1147. # topic: adb57b892b7da0eb46ab54c904f0de9cb1e31e01
  1148. ###
  1149. method redirect_stdout {} {
  1150. my variable ismain
  1151. if { $ismain } return
  1152. set nspace [namespace current]
  1153. set my [namespace which my]
  1154. set newproc ::console:puts
  1155. if {[info command $newproc] eq {}} {
  1156. catch {rename puts $newproc}
  1157. }
  1158. proc ::puts args [string map [list %newproc% $newproc %nspace% $nspace %self% $my] {
  1159. if {[info command %self%] eq {} } {
  1160. uplevel #0 %newproc% $args
  1161. ::rename ::puts {}
  1162. ::rename %newproc% ::puts
  1163. return
  1164. }
  1165. switch -glob -- "[llength $args] $args" {
  1166. {1 *} {
  1167. set msg [lindex $args 0]\n
  1168. set tag ok
  1169. }
  1170. {2 stdout *} {
  1171. set msg [lindex $args 1]\n
  1172. set tag ok
  1173. }
  1174. {2 stderr *} {
  1175. set msg [lindex $args 1]\n
  1176. set tag err
  1177. }
  1178. {2 green *} {
  1179. set msg [lindex $args 1]\n
  1180. set tag grn
  1181. }
  1182. {2 purple *} {
  1183. set msg [lindex $args 1]\n
  1184. set tag purple
  1185. }
  1186. {2 lightblue *} {
  1187. set msg [lindex $args 1]\n
  1188. set tag lblue
  1189. }
  1190. {2 orange *} {
  1191. set msg [lindex $args 1]\n
  1192. set tag orange
  1193. }
  1194. {2 -nonewline *} {
  1195. set msg [lindex $args 1]
  1196. set tag ok
  1197. }
  1198. {3 -nonewline stdout *} {
  1199. set msg [lindex $args 2]
  1200. set tag ok
  1201. }
  1202. {3 -nonewline stderr *} {
  1203. set msg [lindex $args 2]
  1204. set tag err
  1205. }
  1206. default {
  1207. uplevel #0 %newproc% $args
  1208. return
  1209. }
  1210. }
  1211. %self% puts $msg $tag
  1212. }]
  1213. set ismain 1
  1214. return {}
  1215. }
  1216.  
  1217. ###
  1218. # topic: 85c1d45d5027823e4407e59dbdfadca12a15d689
  1219. # description: Prompt for the user to select an input file, the source that file.
  1220. ###
  1221. method SourceFile {} {
  1222. set types {
  1223. {{TCL Scripts} {.tcl}}
  1224. {{All Files} *}
  1225. }
  1226. set f [tk_getOpenFile -filetypes $types -title "TCL Script To Source..."]
  1227. if {$f!=""} {
  1228. uplevel #0 [list source [file normalize $f]]
  1229. }
  1230. }
  1231. }
  1232.  
  1233. ::clay::define ::clay::tk::console.sqlite {
  1234. clay set option db {class organ}
  1235. clay set option prompt {default {sqlite-> }}
  1236. clay set option title {default {SQLite Console}}
  1237. clay set option header {datatype boolean default 1}
  1238. clay set option mode {widget select default column values {line list column csv multicolumn}}
  1239.  
  1240.  
  1241. ###
  1242. # topic: 43e235cf3b612e95c590e5de400d4bcc39d622a4
  1243. # description:
  1244. # Execute a single SQL command. Pay special attention to control
  1245. # directives that begin with "."
  1246. #
  1247. # The return value is the text output from the command, properly
  1248. # formatted.
  1249. ###
  1250. method DoCommand cmd {
  1251. my clay delegate db [my Config_get db]
  1252. my variable v
  1253. set mode [my Config_get mode]
  1254. set header [my Config_get header]
  1255. if {[regexp {^(\.[a-z]+)} $cmd all word]} {
  1256. if {$word==".tcl"} {
  1257. my tcl_console
  1258. return {}
  1259. } elseif {$word==".mode"} {
  1260. regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
  1261. my config set [list mode $newvalue]
  1262. return {}
  1263. } elseif {$word==".exit"} {
  1264. my destroy
  1265. return {}
  1266. } elseif {$word==".header"} {
  1267. regexp {^.[a-z]+ +([a-z]+)} $cmd all newvalue
  1268. my config set [list header $newvalue]
  1269. return {}
  1270. } elseif {$word==".tables"} {
  1271. set mode multicolumn
  1272. set cmd {SELECT name FROM sqlite_master WHERE type='table'
  1273. UNION ALL
  1274. SELECT name FROM sqlite_temp_master WHERE type='table'}
  1275. my <db> eval {PRAGMA database_list} {
  1276. if {$name!="temp" && $name!="main"} {
  1277. append cmd "UNION ALL SELECT name FROM $name.sqlite_master\
  1278. WHERE type='table'"
  1279. }
  1280. }
  1281. append cmd { ORDER BY 1}
  1282. } elseif {$word==".fullschema"} {
  1283. set pattern %
  1284. regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
  1285. set mode list
  1286. set header 0
  1287. set cmd "SELECT sql FROM sqlite_master WHERE tbl_name LIKE '$pattern'
  1288. AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
  1289. WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
  1290. my <db> eval {PRAGMA database_list} {
  1291. if {$name!="temp" && $name!="main"} {
  1292. append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
  1293. WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
  1294. }
  1295. }
  1296. } elseif {$word==".schema"} {
  1297. set pattern %
  1298. regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
  1299. set mode list
  1300. set header 0
  1301. set cmd "SELECT sql FROM sqlite_master WHERE name LIKE '$pattern'
  1302. AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
  1303. WHERE name LIKE '$pattern' AND sql NOT NULL"
  1304. my <db> eval {PRAGMA database_list} {
  1305. if {$name!="temp" && $name!="main"} {
  1306. append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
  1307. WHERE name LIKE '$pattern' AND sql NOT NULL"
  1308. }
  1309. }
  1310. } else {
  1311. return \
  1312. ".exit\n.mode line|list|column|csv\n.schema ?TABLENAME?\n.tables\n.tcl"
  1313. }
  1314. }
  1315. set res {}
  1316. if {$mode=="list"} {
  1317. my <db> eval $cmd x {
  1318. set sep {}
  1319. foreach col $x(*) {
  1320. append res $sep$x($col)
  1321. set sep |
  1322. }
  1323. append res \n
  1324. }
  1325. if {[info exists x(*)] && $header} {
  1326. set sep {}
  1327. set hdr {}
  1328. foreach col $x(*) {
  1329. append hdr $sep$col
  1330. set sep |
  1331. }
  1332. set res $hdr\n$res
  1333. }
  1334. } elseif {[string range $mode 0 2]=="col"} {
  1335. set y {}
  1336. my <db> eval $cmd x {
  1337. foreach col $x(*) {
  1338. if {![info exists cw($col)] || $cw($col)<[string length $x($col)]} {
  1339. set cw($col) [string length $x($col)]
  1340. }
  1341. lappend y $x($col)
  1342. }
  1343. }
  1344. if {[info exists x(*)] && $header} {
  1345. set hdr {}
  1346. set ln {}
  1347. set dash ---------------------------------------------------------------
  1348. append dash ------------------------------------------------------------
  1349. foreach col $x(*) {
  1350. if {![info exists cw($col)] || $cw($col)<[string length $col]} {
  1351. set cw($col) [string length $col]
  1352. }
  1353. lappend hdr $col
  1354. lappend ln [string range $dash 1 $cw($col)]
  1355. }
  1356. set y [concat $hdr $ln $y]
  1357. }
  1358. if {[info exists x(*)]} {
  1359. set format {}
  1360. set arglist {}
  1361. set arglist2 {}
  1362. set i 0
  1363. foreach col $x(*) {
  1364. lappend arglist x$i
  1365. append arglist2 " \$x$i"
  1366. incr i
  1367. append format " %-$cw($col)s"
  1368. }
  1369. set format [string trimleft $format]\n
  1370. if {[llength $arglist]>0} {
  1371. foreach $arglist $y "append res \[format [list $format] $arglist2\]"
  1372. }
  1373. }
  1374. } elseif {$mode=="multicolumn"} {
  1375. set y [my <db> eval $cmd]
  1376. set max 0
  1377. foreach e $y {
  1378. if {$max<[string length $e]} {set max [string length $e]}
  1379. }
  1380. set ncol [expr {int(80/($max+2))}]
  1381. if {$ncol<1} {set ncol 1}
  1382. set nelem [llength $y]
  1383. set nrow [expr {($nelem+$ncol-1)/$ncol}]
  1384. set format "%-${max}s"
  1385. for {set i 0} {$i<$nrow} {incr i} {
  1386. set j $i
  1387. while 1 {
  1388. append res [format $format [lindex $y $j]]
  1389. incr j $nrow
  1390. if {$j>=$nelem} break
  1391. append res { }
  1392. }
  1393. append res \n
  1394. }
  1395. } elseif {$mode=="csv"} {
  1396. my <db> eval $cmd x {
  1397. set sep {}
  1398. foreach col $x(*) {
  1399. set val $x($col)
  1400. if {$val=="" || [regexp {[\s",]} $val]} {
  1401. set val \"[string map [list \" \"\"] $val]\"
  1402. }
  1403. append res $sep$val
  1404. set sep ,
  1405. }
  1406. append res \n
  1407. }
  1408. } else {
  1409. my <db> eval $cmd x {
  1410. foreach col $x(*) {append res "$col = $x($col)\n"}
  1411. append res \n
  1412. }
  1413. }
  1414. return [string trimright $res]
  1415. }
  1416.  
  1417. ###
  1418. # topic: 93d94ab333ba8ad804eefcc8bba8afa95b1e0dcf
  1419. ###
  1420. method Enter {} {
  1421. my variable v
  1422. set w [my clay delegate text]
  1423. scan [my <text> index insert] %d.%d row col
  1424. set start $row.$v(plength)
  1425. set line [my <text> get $start "$start lineend"]
  1426. my <text> insert end \n
  1427. my <text> mark set out end
  1428. if {$v(prior)==""} {
  1429. set cmd $line
  1430. } else {
  1431. set cmd $v(prior)\n$line
  1432. }
  1433. if {[string index $cmd 0]=="." || [my <db> complete $cmd]} {
  1434. regsub -all {\n} [string trim $cmd] { } cmd2
  1435. my addHistory $cmd2
  1436. set rc [catch {my DoCommand $cmd} res]
  1437. if {![winfo exists $w]} return
  1438. if {$rc} {
  1439. my <text> insert end $res\n err
  1440. } elseif {[string length $res]>0} {
  1441. my <text> insert end $res\n ok
  1442. }
  1443. set v(prior) {}
  1444. my <text> insert end $v(prompt)
  1445. } else {
  1446. set v(prior) $cmd
  1447. regsub -all {[^ ]} $v(prompt) . x
  1448. my <text> insert end $x
  1449. }
  1450. my <text> mark set insert end
  1451. my <text> mark set out {insert linestart}
  1452. my <text> yview insert
  1453. }
  1454.  
  1455. method tcl_console {} {
  1456. set w [my widget toplevel]
  1457. if {$w ne "."} {
  1458. console:start
  1459. } else {
  1460. if {[winfo exists .tclconsole]} {
  1461. catch {wm deiconify .tclconsole}
  1462. update
  1463. catch {raise .tclconsole}
  1464. } else {
  1465. set args [list -prompt {wish% } -title {Tcl/Tk Shell}]
  1466. taotk::console .tclconsole {*}$args
  1467. }
  1468. .tclconsole redirect_stdout
  1469. wm title .tclconsole "TCL [my Config_get title]"
  1470. .tclconsole puts "SQL Object Available as [my Config_get db]" green
  1471. }
  1472. }
  1473. }
  1474.  
  1475. # Start the console
  1476. #
  1477. # console:create {.@console} {% } {Tcl/Tk Console}
  1478.