third_party/sqlite/sqlite-src-3080704/contrib/sqlitecon.tcl

   1 # A Tk console widget for SQLite.  Invoke sqlitecon::create with a window name,
   2 # a prompt string, a title to set a new top-level window, and the SQLite
   3 # database handle.  For example:
   4 #
   5 #     sqlitecon::create .sqlcon {sql:- } {SQL Console} db
   6 #
   7 # A toplevel window is created that allows you to type in SQL commands to
   8 # be processed on the spot.
   9 #
  10 # A limited set of dot-commands are supported:
  11 #
  12 #     .table
  13 #     .schema ?TABLE?
  14 #     .mode list|column|multicolumn|line
  15 #     .exit
  16 #
  17 # In addition, a new SQL function named "edit()" is created.  This function
  18 # takes a single text argument and returns a text result.  Whenever the
  19 # the function is called, it pops up a new toplevel window containing a
  20 # text editor screen initialized to the argument.  When the "OK" button
  21 # is pressed, whatever revised text is in the text editor is returned as
  22 # the result of the edit() function.  This allows text fields of SQL tables
  23 # to be edited quickly and easily as follows:
  24 #
  25 #    UPDATE table1 SET dscr = edit(dscr) WHERE rowid=15;
  26 #
  27
  28
  29 # Create a namespace to work in
  30 #
  31 namespace eval ::sqlitecon {
  32   # do nothing
  33 }
  34
  35 # Create a console widget named $w.  The prompt string is $prompt.
  36 # The title at the top of the window is $title.  The database connection
  37 # object is $db
  38 #
  39 proc sqlitecon::create {w prompt title db} {
  40   upvar #0 $w.t v
  41   if {[winfo exists $w]} {destroy $w}
  42   if {[info exists v]} {unset v}
  43   toplevel $w
  44   wm title $w $title
  45   wm iconname $w $title
  46   frame $w.mb -bd 2 -relief raised
  47   pack $w.mb -side top -fill x
  48   menubutton $w.mb.file -text File -menu $w.mb.file.m
  49   menubutton $w.mb.edit -text Edit -menu $w.mb.edit.m
  50   pack $w.mb.file $w.mb.edit -side left -padx 8 -pady 1
  51   set m [menu $w.mb.file.m -tearoff 0]
  52   $m add command -label {Close} -command "destroy $w"
  53   sqlitecon::create_child $w $prompt $w.mb.edit.m
  54   set v(db) $db
  55   $db function edit ::sqlitecon::_edit
  56 }
  57
  58 # This routine creates a console as a child window within a larger
  59 # window.  It also creates an edit menu named "$editmenu" if $editmenu!="".
  60 # The calling function is responsible for posting the edit menu.
  61 #
  62 proc sqlitecon::create_child {w prompt editmenu} {
  63   upvar #0 $w.t v
  64   if {$editmenu!=""} {
  65     set m [menu $editmenu -tearoff 0]
  66     $m add command -label Cut -command "sqlitecon::Cut $w.t"
  67     $m add command -label Copy -command "sqlitecon::Copy $w.t"
  68     $m add command -label Paste -command "sqlitecon::Paste $w.t"
  69     $m add command -label {Clear Screen} -command "sqlitecon::Clear $w.t"
  70     $m add separator
  71     $m add command -label {Save As...} -command "sqlitecon::SaveFile $w.t"
  72     catch {$editmenu config -postcommand "sqlitecon::EnableEditMenu $w"}
  73   }
  74   scrollbar $w.sb -orient vertical -command "$w.t yview"
  75   pack $w.sb -side right -fill y
  76   text $w.t -font fixed -yscrollcommand "$w.sb set"
  77   pack $w.t -side right -fill both -expand 1
  78   bindtags $w.t Sqlitecon
  79   set v(editmenu) $editmenu
  80   set v(history) 0
  81   set v(historycnt) 0
  82   set v(current) -1
  83   set v(prompt) $prompt
  84   set v(prior) {}
  85   set v(plength) [string length $v(prompt)]
  86   set v(x) 0
  87   set v(y) 0
  88   set v(mode) column
  89   set v(header) on
  90   $w.t mark set insert end
  91   $w.t tag config ok -foreground blue
  92   $w.t tag config err -foreground red
  93   $w.t insert end $v(prompt)
  94   $w.t mark set out 1.0
  95   after idle "focus $w.t"
  96 }
  97
  98 bind Sqlitecon <1> {sqlitecon::Button1 %W %x %y}
  99 bind Sqlitecon <B1-Motion> {sqlitecon::B1Motion %W %x %y}
 100 bind Sqlitecon <B1-Leave> {sqlitecon::B1Leave %W %x %y}
 101 bind Sqlitecon <B1-Enter> {sqlitecon::cancelMotor %W}
 102 bind Sqlitecon <ButtonRelease-1> {sqlitecon::cancelMotor %W}
 103 bind Sqlitecon <KeyPress> {sqlitecon::Insert %W %A}
 104 bind Sqlitecon <Left> {sqlitecon::Left %W}
 105 bind Sqlitecon <Control-b> {sqlitecon::Left %W}
 106 bind Sqlitecon <Right> {sqlitecon::Right %W}
 107 bind Sqlitecon <Control-f> {sqlitecon::Right %W}
 108 bind Sqlitecon <BackSpace> {sqlitecon::Backspace %W}
 109 bind Sqlitecon <Control-h> {sqlitecon::Backspace %W}
 110 bind Sqlitecon <Delete> {sqlitecon::Delete %W}
 111 bind Sqlitecon <Control-d> {sqlitecon::Delete %W}
 112 bind Sqlitecon <Home> {sqlitecon::Home %W}
 113 bind Sqlitecon <Control-a> {sqlitecon::Home %W}
 114 bind Sqlitecon <End> {sqlitecon::End %W}
 115 bind Sqlitecon <Control-e> {sqlitecon::End %W}
 116 bind Sqlitecon <Return> {sqlitecon::Enter %W}
 117 bind Sqlitecon <KP_Enter> {sqlitecon::Enter %W}
 118 bind Sqlitecon <Up> {sqlitecon::Prior %W}
 119 bind Sqlitecon <Control-p> {sqlitecon::Prior %W}
 120 bind Sqlitecon <Down> {sqlitecon::Next %W}
 121 bind Sqlitecon <Control-n> {sqlitecon::Next %W}
 122 bind Sqlitecon <Control-k> {sqlitecon::EraseEOL %W}
 123 bind Sqlitecon <<Cut>> {sqlitecon::Cut %W}
 124 bind Sqlitecon <<Copy>> {sqlitecon::Copy %W}
 125 bind Sqlitecon <<Paste>> {sqlitecon::Paste %W}
 126 bind Sqlitecon <<Clear>> {sqlitecon::Clear %W}
 127
 128 # Insert a single character at the insertion cursor
 129 #
 130 proc sqlitecon::Insert {w a} {
 131   $w insert insert $a
 132   $w yview insert
 133 }
 134
 135 # Move the cursor one character to the left
 136 #
 137 proc sqlitecon::Left {w} {
 138   upvar #0 $w v
 139   scan [$w index insert] %d.%d row col
 140   if {$col>$v(plength)} {
 141     $w mark set insert "insert -1c"
 142   }
 143 }
 144
 145 # Erase the character to the left of the cursor
 146 #
 147 proc sqlitecon::Backspace {w} {
 148   upvar #0 $w v
 149   scan [$w index insert] %d.%d row col
 150   if {$col>$v(plength)} {
 151     $w delete {insert -1c}
 152   }
 153 }
 154
 155 # Erase to the end of the line
 156 #
 157 proc sqlitecon::EraseEOL {w} {
 158   upvar #0 $w v
 159   scan [$w index insert] %d.%d row col
 160   if {$col>=$v(plength)} {
 161     $w delete insert {insert lineend}
 162   }
 163 }
 164
 165 # Move the cursor one character to the right
 166 #
 167 proc sqlitecon::Right {w} {
 168   $w mark set insert "insert +1c"
 169 }
 170
 171 # Erase the character to the right of the cursor
 172 #
 173 proc sqlitecon::Delete w {
 174   $w delete insert
 175 }
 176
 177 # Move the cursor to the beginning of the current line
 178 #
 179 proc sqlitecon::Home w {
 180   upvar #0 $w v
 181   scan [$w index insert] %d.%d row col
 182   $w mark set insert $row.$v(plength)
 183 }
 184
 185 # Move the cursor to the end of the current line
 186 #
 187 proc sqlitecon::End w {
 188   $w mark set insert {insert lineend}
 189 }
 190
 191 # Add a line to the history
 192 #
 193 proc sqlitecon::addHistory {w line} {
 194   upvar #0 $w v
 195   if {$v(historycnt)>0} {
 196     set last [lindex $v(history) [expr $v(historycnt)-1]]
 197     if {[string compare $last $line]} {
 198       lappend v(history) $line
 199       incr v(historycnt)
 200     }
 201   } else {
 202     set v(history) [list $line]
 203     set v(historycnt) 1
 204   }
 205   set v(current) $v(historycnt)
 206 }
 207
 208 # Called when "Enter" is pressed.  Do something with the line
 209 # of text that was entered.
 210 #
 211 proc sqlitecon::Enter w {
 212   upvar #0 $w v
 213   scan [$w index insert] %d.%d row col
 214   set start $row.$v(plength)
 215   set line [$w get $start "$start lineend"]
 216   $w insert end \n
 217   $w mark set out end
 218   if {$v(prior)==""} {
 219     set cmd $line
 220   } else {
 221     set cmd $v(prior)\n$line
 222   }
 223   if {[string index $cmd 0]=="." || [$v(db) complete $cmd]} {
 224     regsub -all {\n} [string trim $cmd] { } cmd2
 225     addHistory $w $cmd2
 226     set rc [catch {DoCommand $w $cmd} res]
 227     if {![winfo exists $w]} return
 228     if {$rc} {
 229       $w insert end $res\n err
 230     } elseif {[string length $res]>0} {
 231       $w insert end $res\n ok
 232     }
 233     set v(prior) {}
 234     $w insert end $v(prompt)
 235   } else {
 236     set v(prior) $cmd
 237     regsub -all {[^ ]} $v(prompt) . x
 238     $w insert end $x
 239   }
 240   $w mark set insert end
 241   $w mark set out {insert linestart}
 242   $w yview insert
 243 }
 244
 245 # Execute a single SQL command.  Pay special attention to control
 246 # directives that begin with "."
 247 #
 248 # The return value is the text output from the command, properly
 249 # formatted.
 250 #
 251 proc sqlitecon::DoCommand {w cmd} {
 252   upvar #0 $w v
 253   set mode $v(mode)
 254   set header $v(header)
 255   if {[regexp {^(\.[a-z]+)} $cmd all word]} {
 256     if {$word==".mode"} {
 257       regexp {^.[a-z]+ +([a-z]+)} $cmd all v(mode)
 258       return {}
 259     } elseif {$word==".exit"} {
 260       destroy [winfo toplevel $w]
 261       return {}
 262     } elseif {$word==".header"} {
 263       regexp {^.[a-z]+ +([a-z]+)} $cmd all v(header)
 264       return {}
 265     } elseif {$word==".tables"} {
 266       set mode multicolumn
 267       set cmd {SELECT name FROM sqlite_master WHERE type='table'
 268                UNION ALL
 269                SELECT name FROM sqlite_temp_master WHERE type='table'}
 270       $v(db) eval {PRAGMA database_list} {
 271          if {$name!="temp" && $name!="main"} {
 272             append cmd "UNION ALL SELECT name FROM $name.sqlite_master\
 273                         WHERE type='table'"
 274          }
 275       }
 276       append cmd  { ORDER BY 1}
 277     } elseif {$word==".fullschema"} {
 278       set pattern %
 279       regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
 280       set mode list
 281       set header 0
 282       set cmd "SELECT sql FROM sqlite_master WHERE tbl_name LIKE '$pattern'
 283                AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
 284                WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
 285       $v(db) eval {PRAGMA database_list} {
 286          if {$name!="temp" && $name!="main"} {
 287             append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
 288                         WHERE tbl_name LIKE '$pattern' AND sql NOT NULL"
 289          }
 290       }
 291     } elseif {$word==".schema"} {
 292       set pattern %
 293       regexp {^.[a-z]+ +([^ ]+)} $cmd all pattern
 294       set mode list
 295       set header 0
 296       set cmd "SELECT sql FROM sqlite_master WHERE name LIKE '$pattern'
 297                AND sql NOT NULL UNION ALL SELECT sql FROM sqlite_temp_master
 298                WHERE name LIKE '$pattern' AND sql NOT NULL"
 299       $v(db) eval {PRAGMA database_list} {
 300          if {$name!="temp" && $name!="main"} {
 301             append cmd " UNION ALL SELECT sql FROM $name.sqlite_master\
 302                         WHERE name LIKE '$pattern' AND sql NOT NULL"
 303          }
 304       }
 305     } else {
 306       return \
 307         ".exit\n.mode line|list|column\n.schema ?TABLENAME?\n.tables"
 308     }
 309   }
 310   set res {}
 311   if {$mode=="list"} {
 312     $v(db) eval $cmd x {
 313       set sep {}
 314       foreach col $x(*) {
 315         append res $sep$x($col)
 316         set sep |
 317       }
 318       append res \n
 319     }
 320     if {[info exists x(*)] && $header} {
 321       set sep {}
 322       set hdr {}
 323       foreach col $x(*) {
 324         append hdr $sep$col
 325         set sep |
 326       }
 327       set res $hdr\n$res
 328     }
 329   } elseif {[string range $mode 0 2]=="col"} {
 330     set y {}
 331     $v(db) eval $cmd x {
 332       foreach col $x(*) {
 333         if {![info exists cw($col)] || $cw($col)<[string length $x($col)]} {
 334            set cw($col) [string length $x($col)]
 335         }
 336         lappend y $x($col)
 337       }
 338     }
 339     if {[info exists x(*)] && $header} {
 340       set hdr {}
 341       set ln {}
 342       set dash ---------------------------------------------------------------
 343       append dash ------------------------------------------------------------
 344       foreach col $x(*) {
 345         if {![info exists cw($col)] || $cw($col)<[string length $col]} {
 346            set cw($col) [string length $col]
 347         }
 348         lappend hdr $col
 349         lappend ln [string range $dash 1 $cw($col)]
 350       }
 351       set y [concat $hdr $ln $y]
 352     }
 353     if {[info exists x(*)]} {
 354       set format {}
 355       set arglist {}
 356       set arglist2 {}
 357       set i 0
 358       foreach col $x(*) {
 359         lappend arglist x$i
 360         append arglist2 " \$x$i"
 361         incr i
 362         append format "  %-$cw($col)s"
 363       }
 364       set format [string trimleft $format]\n
 365       if {[llength $arglist]>0} {
 366         foreach $arglist $y "append res \[format [list $format] $arglist2\]"
 367       }
 368     }
 369   } elseif {$mode=="multicolumn"} {
 370     set y [$v(db) eval $cmd]
 371     set max 0
 372     foreach e $y {
 373       if {$max<[string length $e]} {set max [string length $e]}
 374     }
 375     set ncol [expr {int(80/($max+2))}]
 376     if {$ncol<1} {set ncol 1}
 377     set nelem [llength $y]
 378     set nrow [expr {($nelem+$ncol-1)/$ncol}]
 379     set format "%-${max}s"
 380     for {set i 0} {$i<$nrow} {incr i} {
 381       set j $i
 382       while 1 {
 383         append res [format $format [lindex $y $j]]
 384         incr j $nrow
 385         if {$j>=$nelem} break
 386         append res {  }
 387       }
 388       append res \n
 389     }
 390   } else {
 391     $v(db) eval $cmd x {
 392       foreach col $x(*) {append res "$col = $x($col)\n"}
 393       append res \n
 394     }
 395   }
 396   return [string trimright $res]
 397 }
 398
 399 # Change the line to the previous line
 400 #
 401 proc sqlitecon::Prior w {
 402   upvar #0 $w v
 403   if {$v(current)<=0} return
 404   incr v(current) -1
 405   set line [lindex $v(history) $v(current)]
 406   sqlitecon::SetLine $w $line
 407 }
 408
 409 # Change the line to the next line
 410 #
 411 proc sqlitecon::Next w {
 412   upvar #0 $w v
 413   if {$v(current)>=$v(historycnt)} return
 414   incr v(current) 1
 415   set line [lindex $v(history) $v(current)]
 416   sqlitecon::SetLine $w $line
 417 }
 418
 419 # Change the contents of the entry line
 420 #
 421 proc sqlitecon::SetLine {w line} {
 422   upvar #0 $w v
 423   scan [$w index insert] %d.%d row col
 424   set start $row.$v(plength)
 425   $w delete $start end
 426   $w insert end $line
 427   $w mark set insert end
 428   $w yview insert
 429 }
 430
 431 # Called when the mouse button is pressed at position $x,$y on
 432 # the console widget.
 433 #
 434 proc sqlitecon::Button1 {w x y} {
 435   global tkPriv
 436   upvar #0 $w v
 437   set v(mouseMoved) 0
 438   set v(pressX) $x
 439   set p [sqlitecon::nearestBoundry $w $x $y]
 440   scan [$w index insert] %d.%d ix iy
 441   scan $p %d.%d px py
 442   if {$px==$ix} {
 443     $w mark set insert $p
 444   }
 445   $w mark set anchor $p
 446   focus $w
 447 }
 448
 449 # Find the boundry between characters that is nearest
 450 # to $x,$y
 451 #
 452 proc sqlitecon::nearestBoundry {w x y} {
 453   set p [$w index @$x,$y]
 454   set bb [$w bbox $p]
 455   if {![string compare $bb ""]} {return $p}
 456   if {($x-[lindex $bb 0])<([lindex $bb 2]/2)} {return $p}
 457   $w index "$p + 1 char"
 458 }
 459
 460 # This routine extends the selection to the point specified by $x,$y
 461 #
 462 proc sqlitecon::SelectTo {w x y} {
 463   upvar #0 $w v
 464   set cur [sqlitecon::nearestBoundry $w $x $y]
 465   if {[catch {$w index anchor}]} {
 466     $w mark set anchor $cur
 467   }
 468   set anchor [$w index anchor]
 469   if {[$w compare $cur != $anchor] || (abs($v(pressX) - $x) >= 3)} {
 470     if {$v(mouseMoved)==0} {
 471       $w tag remove sel 0.0 end
 472     }
 473     set v(mouseMoved) 1
 474   }
 475   if {[$w compare $cur < anchor]} {
 476     set first $cur
 477     set last anchor
 478   } else {
 479     set first anchor
 480     set last $cur
 481   }
 482   if {$v(mouseMoved)} {
 483     $w tag remove sel 0.0 $first
 484     $w tag add sel $first $last
 485     $w tag remove sel $last end
 486     update idletasks
 487   }
 488 }
 489
 490 # Called whenever the mouse moves while button-1 is held down.
 491 #
 492 proc sqlitecon::B1Motion {w x y} {
 493   upvar #0 $w v
 494   set v(y) $y
 495   set v(x) $x
 496   sqlitecon::SelectTo $w $x $y
 497 }
 498
 499 # Called whenever the mouse leaves the boundries of the widget
 500 # while button 1 is held down.
 501 #
 502 proc sqlitecon::B1Leave {w x y} {
 503   upvar #0 $w v
 504   set v(y) $y
 505   set v(x) $x
 506   sqlitecon::motor $w
 507 }
 508
 509 # This routine is called to automatically scroll the window when
 510 # the mouse drags offscreen.
 511 #
 512 proc sqlitecon::motor w {
 513   upvar #0 $w v
 514   if {![winfo exists $w]} return
 515   if {$v(y)>=[winfo height $w]} {
 516     $w yview scroll 1 units
 517   } elseif {$v(y)<0} {
 518     $w yview scroll -1 units
 519   } else {
 520     return
 521   }
 522   sqlitecon::SelectTo $w $v(x) $v(y)
 523   set v(timer) [after 50 sqlitecon::motor $w]
 524 }
 525
 526 # This routine cancels the scrolling motor if it is active
 527 #
 528 proc sqlitecon::cancelMotor w {
 529   upvar #0 $w v
 530   catch {after cancel $v(timer)}
 531   catch {unset v(timer)}
 532 }
 533
 534 # Do a Copy operation on the stuff currently selected.
 535 #
 536 proc sqlitecon::Copy w {
 537   if {![catch {set text [$w get sel.first sel.last]}]} {
 538      clipboard clear -displayof $w
 539      clipboard append -displayof $w $text
 540   }
 541 }
 542
 543 # Return 1 if the selection exists and is contained
 544 # entirely on the input line.  Return 2 if the selection
 545 # exists but is not entirely on the input line.  Return 0
 546 # if the selection does not exist.
 547 #
 548 proc sqlitecon::canCut w {
 549   set r [catch {
 550     scan [$w index sel.first] %d.%d s1x s1y
 551     scan [$w index sel.last] %d.%d s2x s2y
 552     scan [$w index insert] %d.%d ix iy
 553   }]
 554   if {$r==1} {return 0}
 555   if {$s1x==$ix && $s2x==$ix} {return 1}
 556   return 2
 557 }
 558
 559 # Do a Cut operation if possible.  Cuts are only allowed
 560 # if the current selection is entirely contained on the
 561 # current input line.
 562 #
 563 proc sqlitecon::Cut w {
 564   if {[sqlitecon::canCut $w]==1} {
 565     sqlitecon::Copy $w
 566     $w delete sel.first sel.last
 567   }
 568 }
 569
 570 # Do a paste opeation.
 571 #
 572 proc sqlitecon::Paste w {
 573   if {[sqlitecon::canCut $w]==1} {
 574     $w delete sel.first sel.last
 575   }
 576   if {[catch {selection get -displayof $w -selection CLIPBOARD} topaste]
 577     && [catch {selection get -displayof $w -selection PRIMARY} topaste]} {
 578     return
 579   }
 580   if {[info exists ::$w]} {
 581     set prior 0
 582     foreach line [split $topaste \n] {
 583       if {$prior} {
 584         sqlitecon::Enter $w
 585         update
 586       }
 587       set prior 1
 588       $w insert insert $line
 589     }
 590   } else {
 591     $w insert insert $topaste
 592   }
 593 }
 594
 595 # Enable or disable entries in the Edit menu
 596 #
 597 proc sqlitecon::EnableEditMenu w {
 598   upvar #0 $w.t v
 599   set m $v(editmenu)
 600   if {$m=="" || ![winfo exists $m]} return
 601   switch [sqlitecon::canCut $w.t] {
 602     0 {
 603       $m entryconf Copy -state disabled
 604       $m entryconf Cut -state disabled
 605     }
 606     1 {
 607       $m entryconf Copy -state normal
 608       $m entryconf Cut -state normal
 609     }
 610     2 {
 611       $m entryconf Copy -state normal
 612       $m entryconf Cut -state disabled
 613     }
 614   }
 615 }
 616
 617 # Prompt the user for the name of a writable file.  Then write the
 618 # entire contents of the console screen to that file.
 619 #
 620 proc sqlitecon::SaveFile w {
 621   set types {
 622     {{Text Files}  {.txt}}
 623     {{All Files}    *}
 624   }
 625   set f [tk_getSaveFile -filetypes $types -title "Write Screen To..."]
 626   if {$f!=""} {
 627     if {[catch {open $f w} fd]} {
 628       tk_messageBox -type ok -icon error -message $fd
 629     } else {
 630       puts $fd [string trimright [$w get 1.0 end] \n]
 631       close $fd
 632     }
 633   }
 634 }
 635
 636 # Erase everything from the console above the insertion line.
 637 #
 638 proc sqlitecon::Clear w {
 639   $w delete 1.0 {insert linestart}
 640 }
 641
 642 # An in-line editor for SQL
 643 #
 644 proc sqlitecon::_edit {origtxt {title {}}} {
 645   for {set i 0} {[winfo exists .ed$i]} {incr i} continue
 646   set w .ed$i
 647   toplevel $w
 648   wm protocol $w WM_DELETE_WINDOW "$w.b.can invoke"
 649   wm title $w {Inline SQL Editor}
 650   frame $w.b
 651   pack $w.b -side bottom -fill x
 652   button $w.b.can -text Cancel -width 6 -command [list set ::$w 0]
 653   button $w.b.ok -text OK -width 6 -command [list set ::$w 1]
 654   button $w.b.cut -text Cut -width 6 -command [list ::sqlitecon::Cut $w.t]
 655   button $w.b.copy -text Copy -width 6 -command [list ::sqlitecon::Copy $w.t]
 656   button $w.b.paste -text Paste -width 6 -command [list ::sqlitecon::Paste $w.t]
 657   set ::$w {}
 658   pack $w.b.cut $w.b.copy $w.b.paste $w.b.can $w.b.ok\
 659      -side left -padx 5 -pady 5 -expand 1
 660   if {$title!=""} {
 661     label $w.title -text $title
 662     pack $w.title -side top -padx 5 -pady 5
 663   }
 664   text $w.t -bg white -fg black -yscrollcommand [list $w.sb set]
 665   pack $w.t -side left -fill both -expand 1
 666   scrollbar $w.sb -orient vertical -command [list $w.t yview]
 667   pack $w.sb -side left -fill y
 668   $w.t insert end $origtxt
 669
 670   vwait ::$w
 671
 672   if {[set ::$w]} {
 673     set txt [string trimright [$w.t get 1.0 end]]
 674   } else {
 675     set txt $origtxt
 676   }
 677   destroy $w
 678   return $txt
 679 }