Changeset 640 for trunk/gui/scripts
- Timestamp:
- Mar 25, 2007, 3:20:49 PM (17 years ago)
- Location:
- trunk/gui/scripts
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/gui/scripts/bugreport.tcl
r468 r640 101 101 } 102 102 103 bind .bugreport.expl <Control-1><Control-1><Control-Shift-1><Control-Shift-1> { 104 pack forget .bugreport.expl 105 pack .bugreport.details -after .bugreport.ok \ 106 -expand yes -fill both -padx 8 -pady 8 107 } 108 103 109 Rappture::Scroller .bugreport.details -xscrollmode auto -yscrollmode auto 104 110 text .bugreport.details.text -wrap none -
trunk/gui/scripts/filexfer.tcl
r466 r640 154 154 # USAGE: Rappture::filexfer::spool <string> ?<filename>? 155 155 # 156 # Clients use this to send a file off to the user. The <string> 157 # is stored in a file called <filename> in the user's spool directory. 158 # If there is already a file by that name, then the name is modified 159 # to make it unique. Once the string has been stored in the file, 160 # a message is sent to all clients listening, letting them know 161 # that the file is available. 156 # Low-level function used to send a file off to the user. Clients 157 # normally use filexfer::download instead. 158 # 159 # The <string> is stored in a file called <filename> in the user's 160 # spool directory. If there is already a file by that name, then 161 # the name is modified to make it unique. Once the string has been 162 # stored in the file, a message is sent to all clients listening, 163 # letting them know that the file is available. 162 164 # ---------------------------------------------------------------------- 163 165 proc Rappture::filexfer::spool {string {filename "output.txt"}} { … … 224 226 225 227 # ---------------------------------------------------------------------- 226 # USAGE: Rappture::filexfer::upload < description> <callback>228 # USAGE: Rappture::filexfer::upload <toolName> <controlList> <callback> 227 229 # 228 230 # Clients use this to prompt the user to upload a file. The string 229 # <description> is sent to the user in a web form, and the user is 230 # given the opportunity to upload a file. If successful, the 231 # <callback> is invoked to handle the uploaded information. 232 # ---------------------------------------------------------------------- 233 proc Rappture::filexfer::upload {desc callback} { 231 # <toolName> is used to identify the application within the web form. 232 # The <controlList> is a list of controls that could be uploaded: 233 # 234 # { <id1> <label1> <desc1> <id2> <label2> <desc2> ... } 235 # 236 # The user is prompted for each of the controls in <controlList>. 237 # If successful, the <callback> is invoked to handle the uploaded 238 # information. 239 # 240 # If anything goes wrong, this function returns a string that should 241 # be displayed to the user to explain the problem. 242 # ---------------------------------------------------------------------- 243 proc Rappture::filexfer::upload {tool controlList callback} { 234 244 variable enabled 235 245 variable sitelogo … … 243 253 close $fid 244 254 255 # 256 # Substitute the <controlList> into the @REPEAT(...)@ area of 257 # the HTML text. 258 # 259 while {[regexp -indices {@REPEAT\((.+?)\)@} $html match inner]} { 260 foreach {s0 s1} $match break 261 foreach {p0 p1} $inner break 262 set template [string range $html $p0 $p1] 263 264 set expanded "" 265 set n 1 266 foreach {name label desc} $controlList { 267 # this description will sit inside title="..." in HTML 268 regsub -all {\"} $desc "" desc 269 270 append expanded [string map [list \ 271 @INDEX@ $n \ 272 @LABEL@ $label \ 273 @DESCRIPTION@ $desc \ 274 @ID@ $name \ 275 ] $template] 276 incr n 277 } 278 set html [string replace $html $s0 $s1 $expanded] 279 } 280 281 # 282 # Substitute the rest of the @NAME@ fields. 283 # 245 284 set cookie [bakeCookie] 246 285 set uploadcmds($cookie) $callback … … 253 292 set html [string map [list \ 254 293 @COOKIE@ $cookie \ 255 @ DESCRIPTION@ $desc\294 @TOOL@ $tool \ 256 295 @LOGO@ $sitelogo \ 257 296 @STYLESHEET@ $style \ 258 297 ] $html] 259 298 260 spool $html upload.html 261 } 299 set status [catch {spool $html upload.html} result] 300 301 if {$status == 0} { 302 return "Upload starting...\nA web browser page should pop up on your desktop. Use that form to handle the upload operation.\n\nIf the upload form doesn't pop up, make sure that you're allowing pop ups from this site. If it still doesn't pop up, you may be having trouble with the version of Java installed for your browser. See our Support area for details.\n\nClick anywhere to dismiss this message." 303 } else { 304 if {$result == "no clients"} { 305 return "Can't upload files. Looks like you might be having trouble with the version of Java installed for your browser." 306 } elseif {"old client" == $result} { 307 return "For this to work properly, you must first restart your Web browser. You don't need to close down this session. Simply shut down all windows for your Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the upload should work properly." 308 } elseif {"old clients" == $result} { 309 return "There are multiple browser pages connected to this session, and one of them has browser that needs to be restarted.\n\nWhoever didn't get the upload form should restart their Web browser. You don't need to close down this session. Simply shut down all windows for the Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the upload should work properly." 310 } else { 311 bgerror $result 312 } 313 } 314 } else { 315 return "Can't upload data. Upload is not enabled. Is your SESSION variable set? Is there an error in your session resources file?" 316 } 317 return "" 318 } 319 320 # ---------------------------------------------------------------------- 321 # USAGE: Rappture::filexfer::download <string> ?<filename>? 322 # 323 # Clients use this to send a file off to the user. The <string> 324 # is stored in a file called <filename> in the user's spool directory. 325 # If there is already a file by that name, then the name is modified 326 # to make it unique. Once the string has been stored in the file, 327 # a message is sent to all clients listening, letting them know 328 # that the file is available. 329 # 330 # If anything goes wrong, this function returns a string that should 331 # be displayed to the user to explain the problem. 332 # ---------------------------------------------------------------------- 333 proc Rappture::filexfer::download {string {filename "output.txt"}} { 334 variable enabled 335 336 if {$enabled} { 337 set status [catch { 338 Rappture::filexfer::spool $string $filename 339 } result] 340 341 if {$status != 0} { 342 if {$result == "no clients"} { 343 return "Can't download data. Looks like you might be having trouble with the version of Java installed for your browser." 344 } elseif {"old client" == $result} { 345 return "For this to work properly, you must first restart your Web browser. You don't need to close down this session. Simply shut down all windows for your Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the download should work properly." 346 } elseif {"old clients" == $result} { 347 return "There are multiple browser pages connected to this session, and one of them has browser that needs to be restarted.\n\nWhoever didn't get the download should restart their Web browser. You don't need to close down this session. Simply shut down all windows for the Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the download should work properly." 348 } else { 349 bgerror $result 350 } 351 } 352 } else { 353 return "Can't download data. Download is not enabled. Is your SESSION variable set? Is there an error in your session resources file?" 354 } 355 return "" 262 356 } 263 357 … … 393 487 -connection $headers(Connection) 394 488 response $cid error -message "Your browser sent a request that this server could not understand.<P>$errmsg" 489 flush $cid 395 490 } else { 396 491 # process the request... … … 412 507 -connection $headers(Connection) 413 508 response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>" 509 flush $cid 414 510 } 415 511 } … … 438 534 -connection $headers(Connection) 439 535 response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>" 536 flush $cid 440 537 } 441 538 } … … 513 610 </html> 514 611 } $port $user $cookie] 612 flush $cid 515 613 } elseif {[regexp {^/?spool\/([^/]+)/(.+)$} $url match session tail]} { 516 614 # … … 530 628 response $cid file -path $file -connection $headers(Connection) 531 629 } 630 flush $cid 532 631 } elseif {[regexp {^/?[a-zA-Z0-9_]+\.[a-zA-Z]+$} $url match]} { 533 632 # … … 537 636 set file [file join $RapptureGUI::library filexfer $url] 538 637 response $cid file -path $file -connection $headers(Connection) 638 flush $cid 539 639 } else { 540 640 # … … 547 647 -connection $headers(Connection) 548 648 response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server." 649 flush $cid 549 650 } 550 651 } … … 678 779 if {[info exists post(callback)] 679 780 && [info exists uploadcmds($post(callback))]} { 680 # get the data -- either text or file 681 set dlist [list which $post(which)] 682 lappend dlist data $post($post(which)) 683 684 # get the upload callback command 781 685 782 set cmd $uploadcmds($post(callback)) 686 if {[catch "$cmd $dlist" result]} { 687 bgerror $result 783 set gotdata 0 784 785 set i 1 786 while {[info exists post(path$i)]} { 787 set path $post(path$i) 788 set data "$post(which$i)$i" 789 790 # get the data -- either text or file 791 set dlist [list which $post(which$i)] 792 793 if {![regexp {[\000-\010\013\014\016-\037\177-]} $post($data)]} { 794 # not a binary file? then trim extra spaces 795 set post($data) [string trim $post($data)] 796 } 797 if {[string length $post($data)] > 0} { 798 set gotdata 1 799 800 # invoke the upload callback command 801 lappend dlist data $post($data) 802 if {[catch "$cmd [list $path] $dlist" result]} { 803 bgerror $result 804 } 805 } 806 incr i 807 } 808 809 # 810 # If there was no data, then warn the user. 811 # 812 if {!$gotdata} { 813 set ninputs [expr {$i-1}] 814 if {$ninputs == 1} { 815 set mesg "You didn't fill in any data on the upload form. 816 817 If you meant up upload data, please try the upload again, and this time select a file name or copy/paste some text." 818 } else { 819 set mesg "You didn't fill in data for any of the $ninputs spots on the upload form. If you leave any of the inputs blank, they are left unchanged so that you can upload into one field without affecting the others. 820 821 If you meant up upload data, please try the upload again, and this time select a file name or copy/paste some text for at least one input." 822 } 823 # invoke the upload callback command to post the error 824 if {[catch "$cmd [list $path error $mesg]" result]} { 825 bgerror $result 826 } 688 827 } 689 828 unset uploadcmds($post(callback)) … … 714 853 </body> 715 854 </html>} 855 flush $cid 716 856 } else { 717 857 # … … 724 864 -connection $headers(Connection) 725 865 response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server." 866 flush $cid 726 867 } 727 868 } -
trunk/gui/scripts/loader.tcl
r437 r640 23 23 24 24 constructor {owner path args} { # defined below } 25 destructor { # defined below } 25 26 26 27 public method value {args} … … 30 31 31 32 protected method _newValue {} 32 protected method _uploadValue {string} 33 protected method _uploadValue {path args} 34 protected method _downloadValues {} 33 35 protected method _tooltip {} 34 36 … … 37 39 private variable _lastlabel "";# label of last example loaded 38 40 39 private variable _uppath "" ;# path to Upload... component 40 private variable _updesc "" ;# description for Upload... data 41 private variable _upfilter "" ;# filter used for upload data 42 43 private variable _dnpath "" ;# path to Download... component 41 private variable _uppath "" ;# list: path label desc ... 42 private variable _dnpaths "" ;# list of download element paths 43 private common _dnpath2state ;# maps download path => yes/no state 44 44 } 45 45 … … 112 112 # 113 113 foreach comp [$_owner xml children -type upload $path] { 114 set topath [$_owner xml get $path.$comp.to] 115 if {"" != $topath} { 116 set _uppath $topath 117 118 set desc [$_owner xml get $path.$comp.prompt] 119 if {"" == $desc} { 120 set desc "Use this form to upload data" 121 set dest [$owner xml get $_uppath.about.label] 122 if {"" != $dest} { 123 append desc " into the $dest area" 124 } 125 append desc "." 126 } 127 set _updesc $desc 128 129 $itk_component(combo) choices insert end @upload "Upload..." 130 break 131 } 114 foreach tcomp [$_owner xml children -type to $path.$comp] { 115 set topath [$_owner xml get $path.$comp.$tcomp] 116 set label [$_owner xml get $topath.about.label] 117 set desc [$_owner xml get $topath.about.description] 118 lappend _uppath $topath $label $desc 119 } 120 break 121 } 122 if {[llength $_uppath] > 0} { 123 $itk_component(combo) choices insert end @upload "Upload..." 132 124 } 133 125 134 126 # 135 127 # If this loader has a <download> section, then create that 136 # entry next. 137 # 128 # entry next. Build a popup for choices if there is more than 129 # one download element. 130 # 131 Rappture::Balloon $itk_component(hull).download \ 132 -title "Choose what to download:" 133 set inner [$itk_component(hull).download component inner] 134 135 set i 0 138 136 foreach comp [$_owner xml children -type download $path] { 139 set frompath [$_owner xml get $path.$comp.from] 140 if {"" != $frompath} { 141 set _dnpath $frompath 142 $itk_component(combo) choices insert end @download "Download..." 143 break 144 } 137 foreach dcomp [$_owner xml children -type from $path.$comp] { 138 set frompath [$_owner xml get $path.$comp.$dcomp] 139 if {"" != $frompath} { 140 lappend _dnpaths $frompath 141 set _dnpath2state($this-$frompath) [expr {$i == 0}] 142 143 set label [$_owner xml get $frompath.about.label] 144 checkbutton $inner.cb$i -text $label \ 145 -variable ::Rappture::Loader::_dnpath2state($this-$frompath) 146 pack $inner.cb$i -anchor w 147 incr i 148 } 149 } 150 } 151 button $inner.go -text "Download" \ 152 -command [itcl::code $this _downloadValues] 153 pack $inner.go -side bottom -padx 50 -pady {4 2} 154 155 if {[llength $_dnpaths] > 0} { 156 $itk_component(combo) choices insert end @download "Download..." 145 157 } 146 158 … … 209 221 210 222 # ---------------------------------------------------------------------- 223 # DESTRUCTOR 224 # ---------------------------------------------------------------------- 225 itcl::body Rappture::Loader::destructor {} { 226 # be sure to clean up entries for this widget's download paths 227 foreach path $_dnpaths { 228 catch {unset _dnpath2state($this-$path)} 229 } 230 } 231 232 # ---------------------------------------------------------------------- 211 233 # USAGE: value ?-check? ?<newval>? 212 234 # … … 283 305 if {$obj == "@upload"} { 284 306 if {[Rappture::filexfer::enabled]} { 285 set status [catch {Rappture::filexfer::upload \ 286 $_updesc [itcl::code $this _uploadValue]} result] 287 if {$status == 0} { 288 Rappture::Tooltip::cue $itk_component(combo) \ 289 "Upload starting...\nA web browser page should pop up on your desktop. Use that form to handle the upload operation.\n\nIf the upload form doesn't pop up, make sure that you're allowing pop ups from this site. If it still doesn't pop up, you may be having trouble with the version of Java installed for your browser. See our Support area for details.\n\nClick anywhere to dismiss this message." 290 } else { 291 if {$result == "no clients"} { 292 Rappture::Tooltip::cue $itk_component(combo) \ 293 "Can't upload files. Looks like you might be having trouble with the version of Java installed for your browser." 294 } elseif {"old client" == $result} { 295 Rappture::Tooltip::cue $itk_component(combo) "For this to work properly, you must first restart your Web browser. You don't need to close down this session. Simply shut down all windows for your Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the upload should work properly." 296 } elseif {"old clients" == $result} { 297 Rappture::Tooltip::cue $itk_component(combo) "There are multiple browser pages connected to this session, and one of them has browser that needs to be restarted.\n\nWhoever didn't get the upload form should restart their Web browser. You don't need to close down this session. Simply shut down all windows for the Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the upload should work properly." 298 } else { 299 bgerror $result 300 } 301 } 302 } else { 303 Rappture::Tooltip::cue $itk_component(combo) \ 304 "Can't upload data. Upload is not enabled. Is your SESSION variable set? Is there an error in your session resources file?" 307 set tool [[$_owner tool] get -name] 308 set mesg [Rappture::filexfer::upload \ 309 $tool $_uppath [itcl::code $this _uploadValue]] 310 311 if {"" != $mesg} { 312 Rappture::Tooltip::cue $itk_component(combo) $mesg 313 } 305 314 } 306 315 … … 312 321 313 322 } elseif {$obj == "@download"} { 314 if {[Rappture::filexfer::enabled]} { 315 set info [$itk_option(-tool) valuefor $_dnpath] 316 set status [catch {Rappture::filexfer::spool $info input.txt} result] 317 if {$status != 0} { 318 if {$result == "no clients"} { 319 Rappture::Tooltip::cue $itk_component(combo) \ 320 "Can't download data. Looks like you might be having trouble with the version of Java installed for your browser." 321 } elseif {"old client" == $result} { 322 Rappture::Tooltip::cue $itk_component(combo) "For this to work properly, you must first restart your Web browser. You don't need to close down this session. Simply shut down all windows for your Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the download should work properly." 323 } elseif {"old clients" == $result} { 324 Rappture::Tooltip::cue $itk_component(combo) "There are multiple browser pages connected to this session, and one of them has browser that needs to be restarted.\n\nWhoever didn't get the download should restart their Web browser. You don't need to close down this session. Simply shut down all windows for the Web browser, then restart the browser and navigate back to this page. You'll find it on \"my nanoHUB\" listed under \"my sessions\". Once the browser is restarted, the download should work properly." 325 } else { 326 bgerror $result 327 } 328 } 323 if {[llength $_dnpaths] == 1} { 324 _downloadValues 329 325 } else { 330 Rappture::Tooltip::cue $itk_component(combo) \ 331 "Can't download data. Download is not enabled. Is your SESSION variable set? Is there an error in your session resources file?" 326 $itk_component(hull).download activate $itk_component(combo) below 332 327 } 333 328 … … 389 384 390 385 # ---------------------------------------------------------------------- 391 # USAGE: _uploadValue ?<key> <value> <key> <value> ...?386 # USAGE: _uploadValue <path> ?<key> <value> <key> <value> ...? 392 387 # 393 388 # Invoked automatically whenever the user has uploaded data from … … 395 390 # argument) and loads into the destination widget. 396 391 # ---------------------------------------------------------------------- 397 itcl::body Rappture::Loader::_uploadValue {args} { 398 Rappture::Tooltip::cue hide ;# take down the note about the popup window 399 392 itcl::body Rappture::Loader::_uploadValue {path args} { 400 393 array set data $args 401 394 402 if {[string length [string trim $data(data)]] == 0} { 403 switch -- $data(which) { 404 file { 405 set mesg "You indicated that you were uploading a file, but y" 406 } 407 text { 408 set mesg "You indicated that you were uploading text, but y" 409 } 410 default { 411 set mesg "Y" 412 } 413 } 414 Rappture::Tooltip::cue $itk_component(combo) \ 415 "${mesg}ou didn't fill in any data on the upload form." 416 return 417 } 418 419 # 420 # BE CAREFUL: This string may have binary characters that 421 # aren't appropriate for a string editor. Right now, XML 422 # will barf on these characters. Clip them out and be 423 # done with it. 424 # 425 set string $data(data) 426 regsub -all {[\000-\010\013\014\016-\037\177-\377]} $string {} string 427 regsub -all "\r" $string "\n" string 428 $itk_option(-tool) valuefor $_uppath $string 429 430 $itk_component(combo) component entry configure -state normal 431 $itk_component(combo) component entry delete 0 end 432 $itk_component(combo) component entry insert end "Uploaded data" 433 $itk_component(combo) component entry configure -state disabled 434 set _lastlabel "Uploaded data" 395 if {[info exists data(error)]} { 396 Rappture::Tooltip::cue $itk_component(combo) $data(error) 397 } 398 399 if {[info exists data(data)]} { 400 Rappture::Tooltip::cue hide ;# take down note about the popup window 401 $itk_option(-tool) valuefor $path $data(data) 402 403 $itk_component(combo) component entry configure -state normal 404 $itk_component(combo) component entry delete 0 end 405 $itk_component(combo) component entry insert end "Uploaded data" 406 $itk_component(combo) component entry configure -state disabled 407 set _lastlabel "Uploaded data" 408 } 409 } 410 411 # ---------------------------------------------------------------------- 412 # USAGE: _downloadValues 413 # 414 # Used internally to download all values checked by the popup that 415 # controls downloading. Sends the values for the various controls 416 # out to the user by popping up separate browser windows. 417 # ---------------------------------------------------------------------- 418 itcl::body Rappture::Loader::_downloadValues {} { 419 # take down the popup (in case it was posted) 420 $itk_component(hull).download deactivate 421 422 set mesg "" 423 if {[Rappture::filexfer::enabled]} { 424 foreach path $_dnpaths { 425 if {$_dnpath2state($this-$path)} { 426 set info [$itk_option(-tool) valuefor $path] 427 set mesg [Rappture::filexfer::download $info input.txt] 428 if {"" != $mesg} { break } 429 } 430 } 431 } 432 433 if {"" != $mesg} { 434 Rappture::Tooltip::cue $itk_component(combo) $mesg 435 } 435 436 } 436 437 -
trunk/gui/scripts/textentry.tcl
r437 r640 25 25 option add *TextEntry.hintFont \ 26 26 -*-helvetica-medium-r-normal-*-*-100-* widgetDefault 27 option add *TextEntry.binaryFont \ 28 -*-courier-medium-r-normal-*-12-* widgetDefault 27 29 28 30 … … 44 46 45 47 protected method _layout {} 48 protected method _setValue {value} 46 49 protected method _newValue {} 47 50 protected method _edit {option args} 48 51 protected method _fixState {} 52 protected method _uploadValue {args} 53 protected method _downloadValue {} 49 54 50 55 private variable _dispatcher "" ;# dispatcher for !events 51 private variable _owner "" ;# thing managing this control 52 private variable _path "" ;# path in XML to this number 53 54 private variable _mode "" ;# entry or text mode 56 private variable _owner "" ;# thing managing this control 57 private variable _path "" ;# path in XML to this number 58 59 private variable _layout "" ;# entry or full text size 60 private variable _mode "ascii" ;# ascii text or binary data 61 private variable _value "" ;# value inside the widget 55 62 private variable _size "" ;# size hint from XML 56 63 } … … 119 126 } 120 127 set newval [lindex $args 0] 121 if {$_mode == "entry"} { 122 $itk_component(entry) configure -state normal 123 $itk_component(emenu) entryconfigure "Cut" -state normal 124 $itk_component(emenu) entryconfigure "Copy" -state normal 125 $itk_component(emenu) entryconfigure "Paste" -state normal 126 $itk_component(entry) delete 0 end 127 $itk_component(entry) insert 0 $newval 128 if {!$itk_option(-editable)} { 129 $itk_component(entry) configure -state disabled 130 $itk_component(emenu) entryconfigure "Cut" -state disabled 131 $itk_component(emenu) entryconfigure "Copy" -state disabled 132 $itk_component(emenu) entryconfigure "Paste" -state disabled 133 } 134 } elseif {$_mode == "text"} { 135 $itk_component(text) configure -state normal 136 $itk_component(tmenu) entryconfigure "Cut" -state normal 137 $itk_component(tmenu) entryconfigure "Copy" -state normal 138 $itk_component(tmenu) entryconfigure "Paste" -state normal 139 $itk_component(text) delete 1.0 end 140 $itk_component(text) insert end $newval 141 if {!$itk_option(-editable)} { 142 $itk_component(text) configure -state disabled 143 $itk_component(tmenu) entryconfigure "Cut" -state disabled 144 $itk_component(tmenu) entryconfigure "Copy" -state disabled 145 $itk_component(tmenu) entryconfigure "Paste" -state disabled 146 } 147 } 128 _setValue $newval 129 148 130 $_dispatcher event -idle !layout 149 131 event generate $itk_component(hull) <<Value>> … … 157 139 # Query the value and return. 158 140 # 159 if {$_mode == "entry"} { 160 return [$itk_component(entry) get] 161 } elseif {$_mode == "text"} { 162 return [$itk_component(text) get 1.0 end-1char] 141 if {$_mode == "ascii"} { 142 if {$_layout == "entry"} { 143 return [$itk_component(entry) get] 144 } elseif {$_layout == "text"} { 145 return [$itk_component(text) get 1.0 end-1char] 146 } 147 } else { 148 return $_value 163 149 } 164 150 return "" … … 207 193 # 208 194 set val "" 209 if {$_ mode== "entry"} {195 if {$_layout == "entry"} { 210 196 set val [$itk_component(entry) get] 211 } elseif {$_ mode== "text"} {197 } elseif {$_layout == "text"} { 212 198 set val [$itk_component(text) get 1.0 end-1char] 213 199 } … … 235 221 # a requested size of WW characters. 236 222 # 237 if {$_ mode!= "entry"} {223 if {$_layout != "entry"} { 238 224 set val "" 239 if {$_ mode== "text"} {225 if {$_layout == "text"} { 240 226 set val [$itk_component(text) get 1.0 end-1char] 241 227 destroy $itk_component(text) … … 269 255 [itcl::code $this _edit menu emenu %X %Y] 270 256 271 $itk_component(entry) insert end $val 272 if {!$itk_option(-editable)} { 273 $itk_component(entry) configure -state disabled 274 } 275 set _mode "entry" 257 set _layout "entry" 258 _setValue $val 276 259 } 277 260 $itk_component(entry) configure -width $size … … 282 265 # a requested size of HH lines by WW characters. 283 266 # 284 if {$_ mode!= "text"} {267 if {$_layout != "text"} { 285 268 set val "" 286 if {$_ mode== "entry"} {269 if {$_layout == "entry"} { 287 270 set val [$itk_component(entry) get] 288 271 destroy $itk_component(entry) … … 319 302 $itk_component(tmenu) add command -label "Paste" -accelerator "^V" \ 320 303 -command [list event generate $itk_component(text) <<Paste>>] 304 $itk_component(tmenu) add separator 305 $itk_component(tmenu) add command -label "Upload..." \ 306 -command [itcl::code $this _uploadValue -start] 307 $itk_component(tmenu) add command -label "Download" \ 308 -command [itcl::code $this _downloadValue] 321 309 bind $itk_component(text) <<PopupMenu>> \ 322 310 [itcl::code $this _edit menu tmenu %X %Y] 323 311 324 $itk_component(text) insert end $val 325 if {!$itk_option(-editable)} { 326 $itk_component(text) configure -state disabled 327 $itk_component(menu) entryconfigure "Cut" -state disabled 328 $itk_component(menu) entryconfigure "Copy" -state disabled 329 $itk_component(menu) entryconfigure "Paste" -state disabled 330 } 331 set _mode "text" 312 set _layout "text" 313 _setValue $val 332 314 } 333 315 $itk_component(text) configure -width $w -height $h … … 347 329 348 330 # ---------------------------------------------------------------------- 331 # USAGE: _setValue <newValue> 332 # 333 # Used internally to set the value for this widget. If the <newValue> 334 # string is ASCII, then it is stored directly and the widget is enabled 335 # for editing. Otherwise, the value is cached and a representation of 336 # the data is displayed. 337 # ---------------------------------------------------------------------- 338 itcl::body Rappture::TextEntry::_setValue {newval} { 339 if {[regexp {[\000-\010\013\014\016-\037\177-\377]} $newval]} { 340 # looks like a binary file 341 set _mode "binary" 342 set _value $newval 343 set font [option get $itk_component(hull) binaryFont BinaryFont] 344 345 set size [string length $newval] 346 foreach {factor units} { 347 1073741824 GB 348 1048576 MB 349 1024 kB 350 1 bytes 351 } { 352 if {$size/$factor > 0} { 353 if {$factor > 1} { 354 set size [format "%.2f" [expr {double($size)/$factor}]] 355 } 356 break 357 } 358 } 359 360 if {$_layout == "entry" || [string match {*x[01]} $_size]} { 361 set newval "<binary> $size $units" 362 } else { 363 set newval "<binary> $size $units\n\n" 364 set tail "" 365 set len [string length $_value] 366 if {$len > 1600} { 367 set len 1600 368 set tail "..." 369 } 370 371 for {set i 0} {$i < $len} {incr i 8} { 372 append newval [format "%#06x: " $i] 373 set ascii "" 374 for {set j 0} {$j < 8} {incr j} { 375 if {$i+$j < $len} { 376 set char [string index $_value [expr {$i+$j}]] 377 binary scan $char c ichar 378 set hexchar [format "%02x" [expr {0xff & $ichar}]] 379 } else { 380 set char " " 381 set hexchar " " 382 } 383 append newval "$hexchar " 384 if {[regexp {[\000-\037\177-\377]} $char]} { 385 append ascii "." 386 } else { 387 append ascii $char 388 } 389 } 390 append newval " | $ascii\n" 391 } 392 append newval $tail 393 } 394 395 # 396 # HACK ALERT! For now, we use a tmp file to compress/encode. 397 # Rappture should have a built-in function to do this. 398 # 399 set tmpfile "/tmp/bindata[pid]" 400 set fid [open $tmpfile w] 401 fconfigure $fid -encoding binary -translation binary 402 puts -nonewline $fid $_value 403 close $fid 404 set _value "@@RP-ENC:z\n[exec gzip -c $tmpfile | mimencode]" 405 406 } else { 407 # ascii file -- map carriage returns to line feeds 408 set _mode "ascii" 409 set _value "" 410 regsub -all "\r" $newval "\n" newval 411 set font [option get $itk_component(hull) binaryFont Font] 412 } 413 414 if {$_layout == "entry"} { 415 $itk_component(entry) configure -font $font 416 $itk_component(entry) configure -state normal 417 $itk_component(emenu) entryconfigure "Cut" -state normal 418 $itk_component(emenu) entryconfigure "Copy" -state normal 419 $itk_component(emenu) entryconfigure "Paste" -state normal 420 $itk_component(entry) delete 0 end 421 $itk_component(entry) insert 0 $newval 422 if {!$itk_option(-editable) || $_mode == "binary"} { 423 $itk_component(entry) configure -state disabled 424 $itk_component(emenu) entryconfigure "Cut" -state disabled 425 $itk_component(emenu) entryconfigure "Copy" -state disabled 426 $itk_component(emenu) entryconfigure "Paste" -state disabled 427 } 428 } elseif {$_layout == "text"} { 429 $itk_component(text) configure -font $font 430 $itk_component(text) configure -state normal 431 $itk_component(tmenu) entryconfigure "Cut" -state normal 432 $itk_component(tmenu) entryconfigure "Copy" -state normal 433 $itk_component(tmenu) entryconfigure "Paste" -state normal 434 $itk_component(text) delete 1.0 end 435 $itk_component(text) insert end $newval 436 if {!$itk_option(-editable) || $_mode == "binary"} { 437 set hull $itk_component(hull) 438 set dfg [option get $hull disabledForeground Foreground] 439 set dbg [option get $hull disabledBackground Background] 440 $itk_component(text) configure -state disabled \ 441 -background $dbg -foreground $dfg 442 $itk_component(tmenu) entryconfigure "Cut" -state disabled 443 $itk_component(tmenu) entryconfigure "Copy" -state disabled 444 $itk_component(tmenu) entryconfigure "Paste" -state disabled 445 } else { 446 $itk_component(text) configure \ 447 -background $itk_option(-textbackground) \ 448 -foreground $itk_option(-textforeground) 449 } 450 } 451 } 452 453 # ---------------------------------------------------------------------- 349 454 # USAGE: _newValue 350 455 # … … 394 499 set state disabled 395 500 } 396 if {$_ mode== "entry"} {501 if {$_layout == "entry"} { 397 502 $itk_component(entry) configure -state $state 398 503 $itk_component(emenu) entryconfigure "Cut" -state $state 399 504 $itk_component(emenu) entryconfigure "Copy" -state $state 400 505 $itk_component(emenu) entryconfigure "Paste" -state $state 401 } elseif {$_ mode== "text"} {506 } elseif {$_layout == "text"} { 402 507 $itk_component(text) configure -state $state 403 508 $itk_component(tmenu) entryconfigure "Cut" -state $state … … 408 513 409 514 # ---------------------------------------------------------------------- 515 # USAGE: _uploadValue -start 516 # USAGE: _uploadValue -assign <key> <value> <key> <value> ... 517 # 518 # Used internally to initiate an upload operation. Prompts the 519 # user to upload into the text area of this widget. 520 # ---------------------------------------------------------------------- 521 itcl::body Rappture::TextEntry::_uploadValue {args} { 522 switch -- $_layout { 523 entry { set widget $itk_component(entry) } 524 text { set widget $itk_component(text) } 525 default { set widget $itk_component(hull) } 526 } 527 528 set opt [lindex $args 0] 529 switch -- $opt { 530 -start { 531 set tool [[$_owner tool] get -name] 532 set cntls [list $_path [label] [tooltip]] 533 set mesg [Rappture::filexfer::upload \ 534 $tool $cntls [itcl::code $this _uploadValue -assign]] 535 536 if {"" != $mesg} { 537 Rappture::Tooltip::cue $widget $mesg 538 } 539 } 540 -assign { 541 array set data [lrange $args 2 end] ;# skip option and path 542 if {[info exists data(error)]} { 543 Rappture::Tooltip::cue $widget $data(error) 544 } 545 if {[info exists data(data)]} { 546 Rappture::Tooltip::cue hide ;# take down note about the popup 547 _setValue $data(data) 548 } 549 } 550 default { 551 error "bad option \"$opt\": should be -start or -assign" 552 } 553 } 554 } 555 556 # ---------------------------------------------------------------------- 557 # USAGE: _downloadValue 558 # 559 # Used internally to initiate a download operation. Takes the current 560 # value and downloads it to the user in a new browser window. 561 # ---------------------------------------------------------------------- 562 itcl::body Rappture::TextEntry::_downloadValue {} { 563 set mesg [Rappture::filexfer::download [value] input.txt] 564 565 if {"" != $mesg} { 566 switch -- $_layout { 567 entry { set widget $itk_component(entry) } 568 text { set widget $itk_component(text) } 569 default { set widget $itk_component(hull) } 570 } 571 Rappture::Tooltip::cue $widget $mesg 572 } 573 } 574 575 # ---------------------------------------------------------------------- 410 576 # CONFIGURATION OPTION: -editable 411 577 # ---------------------------------------------------------------------- … … 425 591 error "bad value \"$itk_option(-state)\": should be [join $valid {, }]" 426 592 } 427 if {$_ mode== "text"} {593 if {$_layout == "text"} { 428 594 if {$itk_option(-state) == "disabled"} { 429 595 set fg [option get $itk_component(text) disabledForeground Foreground] -
trunk/gui/scripts/tool.tcl
r637 r640 24 24 } { # defined below } 25 25 26 public method get {{option ""}} 26 27 public method installdir {} { return $_installdir } 27 28 … … 62 63 63 64 eval configure $args 65 } 66 67 # ---------------------------------------------------------------------- 68 # USAGE: get ?-option? 69 # 70 # Clients use this to query information about the tool. 71 # ---------------------------------------------------------------------- 72 itcl::body Rappture::Tool::get {{option ""}} { 73 set values(-name) $_appname 74 if {$option == ""} { 75 return [array get values] 76 } 77 if {![info exists values]} { 78 error "bad option \"$option\": should be [join [array names values] {, }]" 79 } 80 return $values($option) 64 81 } 65 82
Note: See TracChangeset
for help on using the changeset viewer.