Changeset 640 for trunk

Timestamp:

Mar 25, 2007, 3:20:49 PM (17 years ago)

Author:

mmc

Message:

Enhanced the <loader> to support upload/download for multiple inputs.
Also, added upload/download options to the right-mouse button menu
for <string> inputs. <string> inputs now accept binary data, so you
can use them to upload binary files.

Location:

trunk/gui

Files:

• filexfer/upload.html (modified) (2 diffs)
• scripts/bugreport.tcl (modified) (1 diff)
• scripts/filexfer.tcl (modified) (14 diffs)
• scripts/loader.tcl (modified) (9 diffs)
• scripts/textentry.tcl (modified) (13 diffs)
• scripts/tool.tcl (modified) (2 diffs)

trunk/gui/filexfer/upload.html

@@ -8 +8 @@
   <script language="JavaScript">
   function setup() {
-    window.resizeTo(750,800);
-    showhide('textcntls','hidden');
+    window.resizeTo(750,750);
+    @REPEAT(
+    showhide('textcntls@INDEX@','hidden');
+    )@
   }
   window.onload = setup;
@@ -32 +34 @@
     <h1>Upload</h1>
     <p id="description">
-      @DESCRIPTION@
+      Use this form to upload data for @TOOL@.  If you don't specify a
+      file for a particular input, that input won't be modified by the
+      <i>Upload</i> operation.
     </p>
 
     <form action="/upload" enctype="multipart/form-data" method="post">
-      <p id="description">
-      I want to:<br/>
-        <input type="radio" name="which" value="file" checked onclick="showhide('filecntls','visible'); showhide('textcntls','hidden')">
-        Upload a file from my desktop<br/>
-        <input type="radio" name="which" value="text" onclick="showhide('filecntls','hidden'); showhide('textcntls','visible')">
-        Copy and paste text<br/>
-      </p>
+    @REPEAT(
+    <div id="input">
+      <div id="heading">
+        @LABEL@:
+      </div>
+      <div id="options">
+        <input type="radio" name="which@INDEX@" value="file" checked onclick="showhide('filecntls@INDEX@','visible'); showhide('textcntls@INDEX@','hidden')">
+        Upload a file</input>
+        <input type="radio" name="which@INDEX@" value="text" onclick="showhide('filecntls@INDEX@','hidden'); showhide('textcntls@INDEX@','visible')">
+        Copy/paste text</input>
+      </div>
+      <div>
+        <div class="incntl" id="filecntls@INDEX@" title="@DESCRIPTION@">
+          <input type="file" name="file@INDEX@">
+        </div>
+        <div class="incntl" id="textcntls@INDEX@" title="@DESCRIPTION@">
+          <textarea rows="20" cols="80" name="text@INDEX@">Copy/paste your text into this area, and then click the Upload button to upload it.</textarea>
+        </div>
+      </div>
+      <input type="hidden" name="path@INDEX@" value="@ID@">
+    </div>
+    )@
 
-      <div id="filecntls">
-        File: <input type="file" name="file">
-      </div>
-      <div id="textcntls">
-        Text: <textarea rows="20" cols="80" name="text"></textarea>
-      </div>
       <input type="hidden" name="callback" value="@COOKIE@">
       <div id="submit">

trunk/gui/scripts/bugreport.tcl

@@ -101 +101 @@
 }
 
+bind .bugreport.expl <Control-1><Control-1><Control-Shift-1><Control-Shift-1> {
+    pack forget .bugreport.expl
+    pack .bugreport.details -after .bugreport.ok \
+        -expand yes -fill both -padx 8 -pady 8
+}
+
 Rappture::Scroller .bugreport.details -xscrollmode auto -yscrollmode auto
 text .bugreport.details.text -wrap none

trunk/gui/scripts/filexfer.tcl

@@ -154 +154 @@
 # USAGE: Rappture::filexfer::spool <string> ?<filename>?
 #
-# Clients use this to send a file off to the user.  The <string>
-# is stored in a file called <filename> in the user's spool directory.
-# If there is already a file by that name, then the name is modified
-# to make it unique.  Once the string has been stored in the file,
-# a message is sent to all clients listening, letting them know
-# that the file is available.
+# Low-level function used to send a file off to the user.  Clients
+# normally use filexfer::download instead.
+#
+# The <string> is stored in a file called <filename> in the user's
+# spool directory.  If there is already a file by that name, then
+# the name is modified to make it unique.  Once the string has been
+# stored in the file, a message is sent to all clients listening,
+# letting them know that the file is available.
 # ----------------------------------------------------------------------
 proc Rappture::filexfer::spool {string {filename "output.txt"}} {
@@ -224 +226 @@
 
 # ----------------------------------------------------------------------
-# USAGE: Rappture::filexfer::upload <description> <callback>
+# USAGE: Rappture::filexfer::upload <toolName> <controlList> <callback>
 #
 # Clients use this to prompt the user to upload a file.  The string
-# <description> is sent to the user in a web form, and the user is
-# given the opportunity to upload a file.  If successful, the
-# <callback> is invoked to handle the uploaded information.
-# ----------------------------------------------------------------------
-proc Rappture::filexfer::upload {desc callback} {
+# <toolName> is used to identify the application within the web form.
+# The <controlList> is a list of controls that could be uploaded:
+#
+#   { <id1> <label1> <desc1>  <id2> <label2> <desc2> ... }
+#
+# The user is prompted for each of the controls in <controlList>.
+# If successful, the <callback> is invoked to handle the uploaded
+# information.
+#
+# If anything goes wrong, this function returns a string that should
+# be displayed to the user to explain the problem.
+# ----------------------------------------------------------------------
+proc Rappture::filexfer::upload {tool controlList callback} {
     variable enabled
     variable sitelogo
@@ -243 +253 @@
         close $fid
 
+        #
+        # Substitute the <controlList> into the @REPEAT(...)@ area of
+        # the HTML text.
+        #
+        while {[regexp -indices {@REPEAT\((.+?)\)@} $html match inner]} {
+            foreach {s0 s1} $match break
+            foreach {p0 p1} $inner break
+            set template [string range $html $p0 $p1]
+
+            set expanded ""
+            set n 1
+            foreach {name label desc} $controlList {
+                # this description will sit inside title="..." in HTML
+                regsub -all {\"} $desc "" desc
+
+                append expanded [string map [list \
+                    @INDEX@ $n \
+                    @LABEL@ $label \
+                    @DESCRIPTION@ $desc \
+                    @ID@ $name \
+                ] $template]
+                incr n
+            }
+            set html [string replace $html $s0 $s1 $expanded]
+        }
+
+        #
+        # Substitute the rest of the @NAME@ fields.
+        #
         set cookie [bakeCookie]
         set uploadcmds($cookie) $callback
@@ -253 +292 @@
         set html [string map [list \
             @COOKIE@ $cookie \
-            @DESCRIPTION@ $desc \
+            @TOOL@ $tool \
             @LOGO@ $sitelogo \
             @STYLESHEET@ $style \
         ] $html]
 
-        spool $html upload.html
-    }
+        set status [catch {spool $html upload.html} result]
+
+        if {$status == 0} {
+            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."
+        } else {
+            if {$result == "no clients"} {
+                return "Can't upload files.  Looks like you might be having trouble with the version of Java installed for your browser."
+            } elseif {"old client" == $result} {
+                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."
+            } elseif {"old clients" == $result} {
+                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."
+            } else {
+                bgerror $result
+            }
+        }
+    } else {
+        return "Can't upload data.  Upload is not enabled.  Is your SESSION variable set?  Is there an error in your session resources file?"
+    }
+    return ""
+}
+
+# ----------------------------------------------------------------------
+# USAGE: Rappture::filexfer::download <string> ?<filename>?
+#
+# Clients use this to send a file off to the user.  The <string>
+# is stored in a file called <filename> in the user's spool directory.
+# If there is already a file by that name, then the name is modified
+# to make it unique.  Once the string has been stored in the file,
+# a message is sent to all clients listening, letting them know
+# that the file is available.
+#
+# If anything goes wrong, this function returns a string that should
+# be displayed to the user to explain the problem.
+# ----------------------------------------------------------------------
+proc Rappture::filexfer::download {string {filename "output.txt"}} {
+    variable enabled
+
+    if {$enabled} {
+        set status [catch {
+            Rappture::filexfer::spool $string $filename
+        } result]
+
+        if {$status != 0} {
+            if {$result == "no clients"} {
+                return "Can't download data.  Looks like you might be having trouble with the version of Java installed for your browser."
+            } elseif {"old client" == $result} {
+                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."
+            } elseif {"old clients" == $result} {
+                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."
+            } else {
+                bgerror $result
+            }
+        }
+    } else {
+        return "Can't download data.  Download is not enabled.  Is your SESSION variable set?  Is there an error in your session resources file?"
+    }
+    return ""
 }
 
@@ -393 +487 @@
                     -connection $headers(Connection)
                 response $cid error -message "Your browser sent a request that this server could not understand.<P>$errmsg"
+                flush $cid
             } else {
                 # process the request...
@@ -412 +507 @@
                             -connection $headers(Connection)
                         response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>"
+                        flush $cid
                     }
                 }
@@ -438 +534 @@
                     -connection $headers(Connection)
                 response $cid error -message "Your browser sent a request that this server could not understand.<P>Invalid request type <b>$type</b>"
+                flush $cid
             }
         }
@@ -513 +610 @@
 </html>
 } $port $user $cookie]
+        flush $cid
     } elseif {[regexp {^/?spool\/([^/]+)/(.+)$} $url match session tail]} {
         #
@@ -530 +628 @@
             response $cid file -path $file -connection $headers(Connection)
         }
+        flush $cid
     } elseif {[regexp {^/?[a-zA-Z0-9_]+\.[a-zA-Z]+$} $url match]} {
         #
@@ -537 +636 @@
         set file [file join $RapptureGUI::library filexfer $url]
         response $cid file -path $file -connection $headers(Connection)
+        flush $cid
     } else {
         #
@@ -547 +647 @@
             -connection $headers(Connection)
         response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server."
+        flush $cid
     }
 }
@@ -678 +779 @@
         if {[info exists post(callback)]
               && [info exists uploadcmds($post(callback))]} {
-            # get the data -- either text or file
-            set dlist [list which $post(which)]
-            lappend dlist data $post($post(which))
-
-            # get the upload callback command
+
             set cmd $uploadcmds($post(callback))
-            if {[catch "$cmd $dlist" result]} {
-                bgerror $result
+            set gotdata 0
+
+            set i 1
+            while {[info exists post(path$i)]} {
+                set path $post(path$i)
+                set data "$post(which$i)$i"
+
+                # get the data -- either text or file
+                set dlist [list which $post(which$i)]
+
+                if {![regexp {[\000-\010\013\014\016-\037\177-]} $post($data)]} {
+                    # not a binary file? then trim extra spaces
+                    set post($data) [string trim $post($data)]
+                }
+                if {[string length $post($data)] > 0} {
+                    set gotdata 1
+
+                    # invoke the upload callback command
+                    lappend dlist data $post($data)
+                    if {[catch "$cmd [list $path] $dlist" result]} {
+                        bgerror $result
+                    }
+                }
+                incr i
+            }
+
+            #
+            # If there was no data, then warn the user.
+            #
+            if {!$gotdata} {
+                set ninputs [expr {$i-1}]
+                if {$ninputs == 1} {
+                    set mesg "You didn't fill in any data on the upload form.
+
+If you meant up upload data, please try the upload again, and this time select a file name or copy/paste some text."
+                } else {
+                    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.
+
+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."
+                }
+                # invoke the upload callback command to post the error
+                if {[catch "$cmd [list $path error $mesg]" result]} {
+                    bgerror $result
+                }
             }
             unset uploadcmds($post(callback))
@@ -714 +853 @@
 </body>
 </html>}
+        flush $cid
     } else {
         #
@@ -724 +864 @@
             -connection $headers(Connection)
         response $cid error -status "404 Not Found" -message "The requested URL $url was not found on this server."
+        flush $cid
     }
 }

trunk/gui/scripts/loader.tcl

@@ -23 +23 @@
 
     constructor {owner path args} { # defined below }
+    destructor { # defined below }
 
     public method value {args}
@@ -30 +31 @@
 
     protected method _newValue {}
-    protected method _uploadValue {string}
+    protected method _uploadValue {path args}
+    protected method _downloadValues {}
     protected method _tooltip {}
 
@@ -37 +39 @@
     private variable _lastlabel "";# label of last example loaded
 
-    private variable _uppath ""   ;# path to Upload... component
-    private variable _updesc ""   ;# description for Upload... data
-    private variable _upfilter "" ;# filter used for upload data
-
-    private variable _dnpath ""   ;# path to Download... component
+    private variable _uppath ""   ;# list: path label desc ...
+    private variable _dnpaths ""  ;# list of download element paths
+    private common _dnpath2state  ;# maps download path => yes/no state
 }
 
@@ -112 +112 @@
     #
     foreach comp [$_owner xml children -type upload $path] {
-        set topath [$_owner xml get $path.$comp.to]
-        if {"" != $topath} {
-            set _uppath $topath
-
-            set desc [$_owner xml get $path.$comp.prompt]
-            if {"" == $desc} {
-                set desc "Use this form to upload data"
-                set dest [$owner xml get $_uppath.about.label]
-                if {"" != $dest} {
-                    append desc " into the $dest area"
-                }
-                append desc "."
-            }
-            set _updesc $desc
-
-            $itk_component(combo) choices insert end @upload "Upload..."
-            break
-        }
+        foreach tcomp [$_owner xml children -type to $path.$comp] {
+            set topath [$_owner xml get $path.$comp.$tcomp]
+            set label [$_owner xml get $topath.about.label]
+            set desc [$_owner xml get $topath.about.description]
+            lappend _uppath $topath $label $desc
+        }
+        break
+    }
+    if {[llength $_uppath] > 0} {
+        $itk_component(combo) choices insert end @upload "Upload..."
     }
 
     #
     # If this loader has a <download> section, then create that
-    # entry next.
-    #
+    # entry next.  Build a popup for choices if there is more than
+    # one download element.
+    #
+    Rappture::Balloon $itk_component(hull).download \
+        -title "Choose what to download:"
+    set inner [$itk_component(hull).download component inner]
+
+    set i 0
     foreach comp [$_owner xml children -type download $path] {
-        set frompath [$_owner xml get $path.$comp.from]
-        if {"" != $frompath} {
-            set _dnpath $frompath
-            $itk_component(combo) choices insert end @download "Download..."
-            break
-        }
+        foreach dcomp [$_owner xml children -type from $path.$comp] {
+            set frompath [$_owner xml get $path.$comp.$dcomp]
+            if {"" != $frompath} {
+                lappend _dnpaths $frompath
+                set _dnpath2state($this-$frompath) [expr {$i == 0}]
+
+                set label [$_owner xml get $frompath.about.label]
+                checkbutton $inner.cb$i -text $label \
+                    -variable ::Rappture::Loader::_dnpath2state($this-$frompath)
+                pack $inner.cb$i -anchor w
+                incr i
+            }
+        }
+    }
+    button $inner.go -text "Download" \
+        -command [itcl::code $this _downloadValues]
+    pack $inner.go -side bottom -padx 50 -pady {4 2}
+
+    if {[llength $_dnpaths] > 0} {
+        $itk_component(combo) choices insert end @download "Download..."
     }
 
@@ -209 +221 @@
 
 # ----------------------------------------------------------------------
+# DESTRUCTOR
+# ----------------------------------------------------------------------
+itcl::body Rappture::Loader::destructor {} {
+    # be sure to clean up entries for this widget's download paths
+    foreach path $_dnpaths {
+        catch {unset _dnpath2state($this-$path)}
+    }
+}
+
+# ----------------------------------------------------------------------
 # USAGE: value ?-check? ?<newval>?
 #
@@ -283 +305 @@
     if {$obj == "@upload"} {
         if {[Rappture::filexfer::enabled]} {
-            set status [catch {Rappture::filexfer::upload \
-                $_updesc [itcl::code $this _uploadValue]} result]
-            if {$status == 0} {
-                Rappture::Tooltip::cue $itk_component(combo) \
-                    "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."
-            } else {
-                if {$result == "no clients"} {
-                    Rappture::Tooltip::cue $itk_component(combo) \
-                        "Can't upload files.  Looks like you might be having trouble with the version of Java installed for your browser."
-                } elseif {"old client" == $result} {
-                    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."
-                } elseif {"old clients" == $result} {
-                    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."
-                } else {
-                    bgerror $result
-                }
-            }
-        } else {
-            Rappture::Tooltip::cue $itk_component(combo) \
-                "Can't upload data.  Upload is not enabled.  Is your SESSION variable set?  Is there an error in your session resources file?"
+            set tool [[$_owner tool] get -name]
+            set mesg [Rappture::filexfer::upload \
+                $tool $_uppath [itcl::code $this _uploadValue]]
+
+            if {"" != $mesg} {
+                Rappture::Tooltip::cue $itk_component(combo) $mesg
+            }
         }
 
@@ -312 +321 @@
 
     } elseif {$obj == "@download"} {
-        if {[Rappture::filexfer::enabled]} {
-            set info [$itk_option(-tool) valuefor $_dnpath]
-            set status [catch {Rappture::filexfer::spool $info input.txt} result]
-            if {$status != 0} {
-                if {$result == "no clients"} {
-                    Rappture::Tooltip::cue $itk_component(combo) \
-                        "Can't download data.  Looks like you might be having trouble with the version of Java installed for your browser."
-                } elseif {"old client" == $result} {
-                    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."
-                } elseif {"old clients" == $result} {
-                    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."
-                } else {
-                    bgerror $result
-                }
-            }
+        if {[llength $_dnpaths] == 1} {
+            _downloadValues
         } else {
-            Rappture::Tooltip::cue $itk_component(combo) \
-                "Can't download data.  Download is not enabled.  Is your SESSION variable set?  Is there an error in your session resources file?"
+            $itk_component(hull).download activate $itk_component(combo) below
         }
 
@@ -389 +384 @@
 
 # ----------------------------------------------------------------------
-# USAGE: _uploadValue ?<key> <value> <key> <value> ...?
+# USAGE: _uploadValue <path> ?<key> <value> <key> <value> ...?
 #
 # Invoked automatically whenever the user has uploaded data from
@@ -395 +390 @@
 # argument) and loads into the destination widget.
 # ----------------------------------------------------------------------
-itcl::body Rappture::Loader::_uploadValue {args} {
-    Rappture::Tooltip::cue hide  ;# take down the note about the popup window
-
+itcl::body Rappture::Loader::_uploadValue {path args} {
     array set data $args
 
-    if {[string length [string trim $data(data)]] == 0} {
-        switch -- $data(which) {
-            file {
-                set mesg "You indicated that you were uploading a file, but y"
-            }
-            text {
-                set mesg "You indicated that you were uploading text, but y"
-            }
-            default {
-                set mesg "Y"
-            }
-        }
-        Rappture::Tooltip::cue $itk_component(combo) \
-            "${mesg}ou didn't fill in any data on the upload form."
-        return
-    }
-
-    #
-    # BE CAREFUL:  This string may have binary characters that
-    #   aren't appropriate for a string editor.  Right now, XML
-    #   will barf on these characters.  Clip them out and be
-    #   done with it.
-    #
-    set string $data(data)
-    regsub -all {[\000-\010\013\014\016-\037\177-\377]} $string {} string
-    regsub -all "\r" $string "\n" string
-    $itk_option(-tool) valuefor $_uppath $string
-
-    $itk_component(combo) component entry configure -state normal
-    $itk_component(combo) component entry delete 0 end
-    $itk_component(combo) component entry insert end "Uploaded data"
-    $itk_component(combo) component entry configure -state disabled
-    set _lastlabel "Uploaded data"
+    if {[info exists data(error)]} {
+        Rappture::Tooltip::cue $itk_component(combo) $data(error)
+    }
+
+    if {[info exists data(data)]} {
+        Rappture::Tooltip::cue hide  ;# take down note about the popup window
+        $itk_option(-tool) valuefor $path $data(data)
+
+        $itk_component(combo) component entry configure -state normal
+        $itk_component(combo) component entry delete 0 end
+        $itk_component(combo) component entry insert end "Uploaded data"
+        $itk_component(combo) component entry configure -state disabled
+        set _lastlabel "Uploaded data"
+    }
+}
+
+# ----------------------------------------------------------------------
+# USAGE: _downloadValues
+#
+# Used internally to download all values checked by the popup that
+# controls downloading.  Sends the values for the various controls
+# out to the user by popping up separate browser windows.
+# ----------------------------------------------------------------------
+itcl::body Rappture::Loader::_downloadValues {} {
+    # take down the popup (in case it was posted)
+    $itk_component(hull).download deactivate
+
+    set mesg ""
+    if {[Rappture::filexfer::enabled]} {
+        foreach path $_dnpaths {
+            if {$_dnpath2state($this-$path)} {
+                set info [$itk_option(-tool) valuefor $path]
+                set mesg [Rappture::filexfer::download $info input.txt]
+                if {"" != $mesg} { break }
+            }
+        }
+    }
+
+    if {"" != $mesg} {
+        Rappture::Tooltip::cue $itk_component(combo) $mesg
+    }
 }
 

trunk/gui/scripts/textentry.tcl

@@ -25 +25 @@
 option add *TextEntry.hintFont \
     -*-helvetica-medium-r-normal-*-*-100-* widgetDefault
+option add *TextEntry.binaryFont \
+    -*-courier-medium-r-normal-*-12-* widgetDefault
 
 
@@ -44 +46 @@
 
     protected method _layout {}
+    protected method _setValue {value}
     protected method _newValue {}
     protected method _edit {option args}
     protected method _fixState {}
+    protected method _uploadValue {args}
+    protected method _downloadValue {}
 
     private variable _dispatcher "" ;# dispatcher for !events
-    private variable _owner ""    ;# thing managing this control
-    private variable _path ""     ;# path in XML to this number
-
-    private variable _mode ""       ;# entry or text mode
+    private variable _owner ""      ;# thing managing this control
+    private variable _path ""       ;# path in XML to this number
+
+    private variable _layout ""     ;# entry or full text size
+    private variable _mode "ascii"  ;# ascii text or binary data
+    private variable _value ""      ;# value inside the widget
     private variable _size ""       ;# size hint from XML
 }
@@ -119 +126 @@
         }
         set newval [lindex $args 0]
-        if {$_mode == "entry"} {
-            $itk_component(entry) configure -state normal
-            $itk_component(emenu) entryconfigure "Cut" -state normal
-            $itk_component(emenu) entryconfigure "Copy" -state normal
-            $itk_component(emenu) entryconfigure "Paste" -state normal
-            $itk_component(entry) delete 0 end
-            $itk_component(entry) insert 0 $newval
-            if {!$itk_option(-editable)} {
-                $itk_component(entry) configure -state disabled
-                $itk_component(emenu) entryconfigure "Cut" -state disabled
-                $itk_component(emenu) entryconfigure "Copy" -state disabled
-                $itk_component(emenu) entryconfigure "Paste" -state disabled
-            }
-        } elseif {$_mode == "text"} {
-            $itk_component(text) configure -state normal
-            $itk_component(tmenu) entryconfigure "Cut" -state normal
-            $itk_component(tmenu) entryconfigure "Copy" -state normal
-            $itk_component(tmenu) entryconfigure "Paste" -state normal
-            $itk_component(text) delete 1.0 end
-            $itk_component(text) insert end $newval
-            if {!$itk_option(-editable)} {
-                $itk_component(text) configure -state disabled
-                $itk_component(tmenu) entryconfigure "Cut" -state disabled
-                $itk_component(tmenu) entryconfigure "Copy" -state disabled
-                $itk_component(tmenu) entryconfigure "Paste" -state disabled
-            }
-        }
+        _setValue $newval
+
         $_dispatcher event -idle !layout
         event generate $itk_component(hull) <<Value>>
@@ -157 +139 @@
     # Query the value and return.
     #
-    if {$_mode == "entry"} {
-        return [$itk_component(entry) get]
-    } elseif {$_mode == "text"} {
-        return [$itk_component(text) get 1.0 end-1char]
+    if {$_mode == "ascii"} {
+        if {$_layout == "entry"} {
+            return [$itk_component(entry) get]
+        } elseif {$_layout == "text"} {
+            return [$itk_component(text) get 1.0 end-1char]
+        }
+    } else {
+        return $_value
     }
     return ""
@@ -207 +193 @@
         #
         set val ""
-        if {$_mode == "entry"} {
+        if {$_layout == "entry"} {
             set val [$itk_component(entry) get]
-        } elseif {$_mode == "text"} {
+        } elseif {$_layout == "text"} {
             set val [$itk_component(text) get 1.0 end-1char]
         }
@@ -235 +221 @@
         # a requested size of WW characters.
         #
-        if {$_mode != "entry"} {
+        if {$_layout != "entry"} {
             set val ""
-            if {$_mode == "text"} {
+            if {$_layout == "text"} {
                 set val [$itk_component(text) get 1.0 end-1char]
                 destroy $itk_component(text)
@@ -269 +255 @@
                 [itcl::code $this _edit menu emenu %X %Y]
 
-            $itk_component(entry) insert end $val
-            if {!$itk_option(-editable)} {
-                $itk_component(entry) configure -state disabled
-            }
-            set _mode "entry"
+            set _layout "entry"
+            _setValue $val
         }
         $itk_component(entry) configure -width $size
@@ -282 +265 @@
         # a requested size of HH lines by WW characters.
         #
-        if {$_mode != "text"} {
+        if {$_layout != "text"} {
             set val ""
-            if {$_mode == "entry"} {
+            if {$_layout == "entry"} {
                 set val [$itk_component(entry) get]
                 destroy $itk_component(entry)
@@ -319 +302 @@
             $itk_component(tmenu) add command -label "Paste" -accelerator "^V" \
                 -command [list event generate $itk_component(text) <<Paste>>]
+            $itk_component(tmenu) add separator
+            $itk_component(tmenu) add command -label "Upload..." \
+                -command [itcl::code $this _uploadValue -start]
+            $itk_component(tmenu) add command -label "Download" \
+                -command [itcl::code $this _downloadValue]
             bind $itk_component(text) <<PopupMenu>> \
                 [itcl::code $this _edit menu tmenu %X %Y]
 
-            $itk_component(text) insert end $val
-            if {!$itk_option(-editable)} {
-                $itk_component(text) configure -state disabled
-                $itk_component(menu) entryconfigure "Cut" -state disabled
-                $itk_component(menu) entryconfigure "Copy" -state disabled
-                $itk_component(menu) entryconfigure "Paste" -state disabled
-            }
-            set _mode "text"
+            set _layout "text"
+            _setValue $val
         }
         $itk_component(text) configure -width $w -height $h
@@ -347 +329 @@
 
 # ----------------------------------------------------------------------
+# USAGE: _setValue <newValue>
+#
+# Used internally to set the value for this widget.  If the <newValue>
+# string is ASCII, then it is stored directly and the widget is enabled
+# for editing.  Otherwise, the value is cached and a representation of
+# the data is displayed.
+# ----------------------------------------------------------------------
+itcl::body Rappture::TextEntry::_setValue {newval} {
+    if {[regexp {[\000-\010\013\014\016-\037\177-\377]} $newval]} {
+        # looks like a binary file
+        set _mode "binary"
+        set _value $newval
+        set font [option get $itk_component(hull) binaryFont BinaryFont]
+
+        set size [string length $newval]
+        foreach {factor units} {
+            1073741824 GB
+            1048576 MB
+            1024 kB
+            1 bytes
+        } {
+            if {$size/$factor > 0} {
+                if {$factor > 1} {
+                    set size [format "%.2f" [expr {double($size)/$factor}]]
+                }
+                break
+            }
+        }
+
+        if {$_layout == "entry" || [string match {*x[01]} $_size]} {
+            set newval "<binary> $size $units"
+        } else {
+            set newval "<binary> $size $units\n\n"
+            set tail ""
+            set len [string length $_value]
+            if {$len > 1600} {
+                set len 1600
+                set tail "..."
+            }
+
+            for {set i 0} {$i < $len} {incr i 8} {
+                append newval [format "%#06x: " $i]
+                set ascii ""
+                for {set j 0} {$j < 8} {incr j} {
+                    if {$i+$j < $len} {
+                        set char [string index $_value [expr {$i+$j}]]
+                        binary scan $char c ichar
+                        set hexchar [format "%02x" [expr {0xff & $ichar}]]
+                    } else {
+                        set char " "
+                        set hexchar "  "
+                    }
+                    append newval "$hexchar "
+                    if {[regexp {[\000-\037\177-\377]} $char]} {
+                        append ascii "."
+                    } else {
+                        append ascii $char
+                    }
+                }
+                append newval " | $ascii\n"
+            }
+            append newval $tail
+        }
+
+        #
+        # HACK ALERT!  For now, we use a tmp file to compress/encode.
+        # Rappture should have a built-in function to do this.
+        #
+        set tmpfile "/tmp/bindata[pid]"
+        set fid [open $tmpfile w]
+        fconfigure $fid -encoding binary -translation binary
+        puts -nonewline $fid $_value
+        close $fid
+        set _value "@@RP-ENC:z\n[exec gzip -c $tmpfile | mimencode]"
+
+    } else {
+        # ascii file -- map carriage returns to line feeds
+        set _mode "ascii"
+        set _value ""
+        regsub -all "\r" $newval "\n" newval
+        set font [option get $itk_component(hull) binaryFont Font]
+    }
+
+    if {$_layout == "entry"} {
+        $itk_component(entry) configure -font $font
+        $itk_component(entry) configure -state normal
+        $itk_component(emenu) entryconfigure "Cut" -state normal
+        $itk_component(emenu) entryconfigure "Copy" -state normal
+        $itk_component(emenu) entryconfigure "Paste" -state normal
+        $itk_component(entry) delete 0 end
+        $itk_component(entry) insert 0 $newval
+        if {!$itk_option(-editable) || $_mode == "binary"} {
+            $itk_component(entry) configure -state disabled
+            $itk_component(emenu) entryconfigure "Cut" -state disabled
+            $itk_component(emenu) entryconfigure "Copy" -state disabled
+            $itk_component(emenu) entryconfigure "Paste" -state disabled
+        }
+    } elseif {$_layout == "text"} {
+        $itk_component(text) configure -font $font
+        $itk_component(text) configure -state normal
+        $itk_component(tmenu) entryconfigure "Cut" -state normal
+        $itk_component(tmenu) entryconfigure "Copy" -state normal
+        $itk_component(tmenu) entryconfigure "Paste" -state normal
+        $itk_component(text) delete 1.0 end
+        $itk_component(text) insert end $newval
+        if {!$itk_option(-editable) || $_mode == "binary"} {
+            set hull $itk_component(hull)
+            set dfg [option get $hull disabledForeground Foreground]
+            set dbg [option get $hull disabledBackground Background]
+            $itk_component(text) configure -state disabled \
+                -background $dbg -foreground $dfg
+            $itk_component(tmenu) entryconfigure "Cut" -state disabled
+            $itk_component(tmenu) entryconfigure "Copy" -state disabled
+            $itk_component(tmenu) entryconfigure "Paste" -state disabled
+        } else {
+            $itk_component(text) configure \
+                -background $itk_option(-textbackground) \
+                -foreground $itk_option(-textforeground)
+        }
+    }
+}
+
+# ----------------------------------------------------------------------
 # USAGE: _newValue
 #
@@ -394 +499 @@
         set state disabled
     }
-    if {$_mode == "entry"} {
+    if {$_layout == "entry"} {
         $itk_component(entry) configure -state $state
         $itk_component(emenu) entryconfigure "Cut" -state $state
         $itk_component(emenu) entryconfigure "Copy" -state $state
         $itk_component(emenu) entryconfigure "Paste" -state $state
-    } elseif {$_mode == "text"} {
+    } elseif {$_layout == "text"} {
         $itk_component(text) configure -state $state
         $itk_component(tmenu) entryconfigure "Cut" -state $state
@@ -408 +513 @@
 
 # ----------------------------------------------------------------------
+# USAGE: _uploadValue -start
+# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
+#
+# Used internally to initiate an upload operation.  Prompts the
+# user to upload into the text area of this widget.
+# ----------------------------------------------------------------------
+itcl::body Rappture::TextEntry::_uploadValue {args} {
+    switch -- $_layout {
+        entry   { set widget $itk_component(entry) }
+        text    { set widget $itk_component(text) }
+        default { set widget $itk_component(hull) }
+    }
+
+    set opt [lindex $args 0]
+    switch -- $opt {
+        -start {
+            set tool [[$_owner tool] get -name]
+            set cntls [list $_path [label] [tooltip]]
+            set mesg [Rappture::filexfer::upload \
+                $tool $cntls [itcl::code $this _uploadValue -assign]]
+
+            if {"" != $mesg} {
+                Rappture::Tooltip::cue $widget $mesg
+            }
+        }
+        -assign {
+            array set data [lrange $args 2 end] ;# skip option and path
+            if {[info exists data(error)]} {
+                Rappture::Tooltip::cue $widget $data(error)
+            }
+            if {[info exists data(data)]} {
+                Rappture::Tooltip::cue hide  ;# take down note about the popup
+                _setValue $data(data)
+            }
+        }
+        default {
+            error "bad option \"$opt\": should be -start or -assign"
+        }
+    }
+}
+
+# ----------------------------------------------------------------------
+# USAGE: _downloadValue
+#
+# Used internally to initiate a download operation.  Takes the current
+# value and downloads it to the user in a new browser window.
+# ----------------------------------------------------------------------
+itcl::body Rappture::TextEntry::_downloadValue {} {
+    set mesg [Rappture::filexfer::download [value] input.txt]
+
+    if {"" != $mesg} {
+        switch -- $_layout {
+            entry   { set widget $itk_component(entry) }
+            text    { set widget $itk_component(text) }
+            default { set widget $itk_component(hull) }
+        }
+        Rappture::Tooltip::cue $widget $mesg
+    }
+}
+
+# ----------------------------------------------------------------------
 # CONFIGURATION OPTION: -editable
 # ----------------------------------------------------------------------
@@ -425 +591 @@
         error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
     }
-    if {$_mode == "text"} {
+    if {$_layout == "text"} {
         if {$itk_option(-state) == "disabled"} {
             set fg [option get $itk_component(text) disabledForeground Foreground]

trunk/gui/scripts/tool.tcl

@@ -24 +24 @@
     } { # defined below }
 
+    public method get {{option ""}}
     public method installdir {} { return $_installdir }
 
@@ -62 +63 @@
 
     eval configure $args
+}
+
+# ----------------------------------------------------------------------
+# USAGE: get ?-option?
+#
+# Clients use this to query information about the tool.
+# ----------------------------------------------------------------------
+itcl::body Rappture::Tool::get {{option ""}} {
+    set values(-name) $_appname
+    if {$option == ""} {
+        return [array get values]
+    }
+    if {![info exists values]} {
+        error "bad option \"$option\": should be [join [array names values] {, }]"
+    }
+    return $values($option)
 }