source: trunk/gui/scripts/imageentry.tcl @ 5044

Last change on this file since 5044 was 3647, checked in by gah, 11 years ago

add string trim to inputs

File size: 14.3 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: ImageEntry - widget for displaying images
4#
5#  This widget represents an <image> entry on a control panel.
6#  It displays images which help explain the input.
7# ======================================================================
8#  AUTHOR:  Michael McLennan, Purdue University
9#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
10#
11#  See the file "license.terms" for information on usage and
12#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13# ======================================================================
14package require Itk
15package require Img
16
17itcl::class Rappture::ImageEntry {
18    inherit itk::Widget
19
20    itk_option define -state state State "normal"
21
22    constructor {owner path args} { # defined below }
23    destructor { # defined below }
24
25    public method value {args}
26
27    public method label {}
28    public method tooltip {}
29
30    protected method _redraw {}
31    protected method _outline {imh color}
32    protected method _uploadValue {args}
33    protected method _downloadValue {}
34
35    private variable _owner ""    ;# thing managing this control
36    private variable _path ""     ;# path in XML to this image
37    private variable _data ""     ;# current image data
38    private variable _imh ""      ;# image handle for current value
39    private variable _resize ""   ;# image for resize operations
40
41    private common _thumbsize 100 ;# std size for thumbnail images
42}
43
44itk::usual ImageEntry {
45    keep -cursor -font
46    keep -foreground -background
47    keep -textbackground
48    keep -selectbackground -selectforeground -selectborderwidth
49}
50
51# ----------------------------------------------------------------------
52# CONSTRUCTOR
53# ----------------------------------------------------------------------
54itcl::body Rappture::ImageEntry::constructor {owner path args} {
55    if {[catch {$owner isa Rappture::ControlOwner} valid] != 0 || !$valid} {
56        error "bad object \"$owner\": should be Rappture::ControlOwner"
57    }
58    set _owner $owner
59    set _path $path
60    set _resize [image create photo]
61
62    #
63    # Create the widget and configure it properly based on other
64    # hints in the XML.  Two ways to display:  Old apps use images
65    # without labels as decorations.  In that case, show the image
66    # alone, probably full size.  Newer apps use images as inputs.
67    # In that case, show a thumbnail of the image with some extra
68    # facts about image type, file size, etc.
69    #
70    itk_component add image {
71        ::label $itk_interior.image -borderwidth 0
72    }
73
74    itk_component add info {
75        ::label $itk_interior.info -borderwidth 0 -width 5 \
76            -anchor w -justify left
77    }
78
79    itk_component add rmenu {
80        menu $itk_interior.menu -tearoff 0
81    } {
82        usual
83        ignore -tearoff
84    }
85    $itk_component(rmenu) add command \
86        -label [Rappture::filexfer::label upload] \
87        -command [itcl::code $this _uploadValue -start]
88    $itk_component(rmenu) add command \
89        -label [Rappture::filexfer::label download] \
90        -command [itcl::code $this _downloadValue]
91
92
93    if {[string length [label]] == 0} {
94        # old mode -- big image
95        pack $itk_component(image) -expand yes -fill both
96        bind $itk_component(image) <Configure> [itcl::code $this _redraw]
97    } else {
98        # new mode -- thumbnail and details
99        pack $itk_component(image) -side left
100        pack $itk_component(info) -side left -expand yes -fill both -padx 4
101
102        bind $itk_component(image) <<PopupMenu>> \
103            [list tk_popup $itk_component(rmenu) %X %Y]
104        bind $itk_component(info) <<PopupMenu>> \
105            [list tk_popup $itk_component(rmenu) %X %Y]
106
107        _redraw  ;# draw Empty image/info
108    }
109
110    # Don't trim this string.  It make be important.
111    set str [$_owner xml get $path.current]
112    if {[string length $str] == 0} {
113        set str [$_owner xml get $path.default]
114    }
115    if {[string length $str] > 0} {
116        value $str
117    }
118
119    eval itk_initialize $args
120}
121
122# ----------------------------------------------------------------------
123# DESTRUCTOR
124# ----------------------------------------------------------------------
125itcl::body Rappture::ImageEntry::destructor {} {
126    if {"" != $_imh} { image delete $_imh }
127    if {"" != $_resize} { image delete $_resize }
128}
129
130# ----------------------------------------------------------------------
131# USAGE: value ?-check? ?<newval>?
132#
133# Clients use this to query/set the value for this widget.  With
134# no args, it returns the current value for the widget.  If the
135# <newval> is specified, it sets the value of the widget and
136# sends a <<Value>> event.  If the -check flag is included, the
137# new value is not actually applied, but just checked for correctness.
138# ----------------------------------------------------------------------
139itcl::body Rappture::ImageEntry::value {args} {
140    set onlycheck 0
141    set i [lsearch -exact $args -check]
142    if {$i >= 0} {
143        set onlycheck 1
144        set args [lreplace $args $i $i]
145    }
146
147    if {[llength $args] == 1} {
148        if {$onlycheck} {
149            # someday we may add validation...
150            return
151        }
152        set newval [lindex $args 0]
153        if {[string length $newval] > 0} {
154            set imh [image create photo -data $newval]
155        } else {
156            set imh ""
157        }
158
159        if {$_imh != ""} {
160            image delete $_imh
161        }
162        set _imh $imh
163        set _data $newval
164
165        _redraw
166
167        return $newval
168
169    } elseif {[llength $args] != 0} {
170        error "wrong # args: should be \"value ?-check? ?newval?\""
171    }
172
173    #
174    # Query the value and return.
175    #
176    set bytes $_data
177    set fmt [string trim [$_owner xml get $_path.convert]]
178    if {"" != $fmt && "" != $_imh} {
179        if {"pgm" == $fmt} { set fmt "ppm -grayscale" }
180        set bytes [eval $_imh data -format $fmt]
181        set bytes [Rappture::encoding::decode -as b64 $bytes]
182    }
183    return $bytes
184}
185
186# ----------------------------------------------------------------------
187# USAGE: label
188#
189# Clients use this to query the label associated with this widget.
190# Reaches into the XML and pulls out the appropriate label string.
191# ----------------------------------------------------------------------
192itcl::body Rappture::ImageEntry::label {} {
193    set label [string trim [$_owner xml get $_path.about.label]]
194    return $label
195}
196
197# ----------------------------------------------------------------------
198# USAGE: tooltip
199#
200# Clients use this to query the tooltip associated with this widget.
201# Reaches into the XML and pulls out the appropriate description
202# string.  Returns the string that should be used with the
203# Rappture::Tooltip facility.
204# ----------------------------------------------------------------------
205itcl::body Rappture::ImageEntry::tooltip {} {
206    set str [string trim [$_owner xml get $_path.about.description]]
207    return $str
208}
209
210# ----------------------------------------------------------------------
211# USAGE: _redraw
212#
213# Used internally to update the image displayed in this entry.
214# If the <resize> parameter is set, then the image is resized.
215# The "auto" value resizes to the current area.  The "width=XX" or
216# "height=xx" form resizes to a particular size.  The "none" value
217# leaves the image as-is; this is the default.
218# ----------------------------------------------------------------------
219itcl::body Rappture::ImageEntry::_redraw {} {
220    if {"" == $_imh} {
221        # generate a big diagonal cross-hatch image
222        set diag [Rappture::icon diag]
223        set dw [image width $diag]
224        set dh [image height $diag]
225        $_resize configure -width $_thumbsize -height $_thumbsize
226        for {set i 0} {$i < $_thumbsize/$dw+1} {incr i} {
227            for {set j 0} {$j < $_thumbsize/$dh+1} {incr j} {
228                set x [expr {$i*$dw}]
229                set y [expr {$j*$dh}]
230                $_resize copy $diag -to $x $y
231            }
232        }
233        _outline $_resize black
234        $itk_component(image) configure -image $_resize
235        $itk_component(info) configure -text "Empty"
236        return
237    }
238
239    set iw [image width $_imh]
240    set ih [image height $_imh]
241    $itk_component(image) configure -image "" -width $iw -height $ih
242
243    #
244    # Build a description of the image if the info is showing.
245    #
246    set desc ""
247    if {[string length [label]] != 0} {
248        # if data is base64-encoded, try to decode it
249        if {![regexp {^[a-zA-Z0-9+/=]+(\n[a-zA-Z0-9+/=]+)*$} $_data]
250              || [catch {Rappture::encoding::decode -as b64 $_data} bytes]} {
251            # oops! not base64 -- use data directly
252            set bytes $_data
253        }
254        set desc [Rappture::utils::datatype $bytes]
255        if {[string equal $desc "Binary data"]} {
256            # generic description -- we can do a little better
257            set iw [image width $_imh]
258            set ih [image height $_imh]
259            set desc "Image, ${iw} x ${ih}"
260        }
261        append desc "\n[Rappture::utils::binsize [string length $_data]]"
262    }
263    $itk_component(info) configure -text $desc
264
265    #
266    # Put up the preview image, resizing if necessary.
267    #
268    set str [string trim [$_owner xml get $_path.resize]]
269    if {"" == $str} {
270        set str "none"
271    }
272    switch -glob -- $str {
273        width=* - height=* {
274            if {[regexp {^width=([0-9]+)$} $str match size]} {
275                set w $size
276                set h [expr {round($w*$ih/double($iw))}]
277                $_resize configure -width $w -height $h
278                $_resize blank
279                blt::winop resample $_imh $_resize box
280                _outline $_resize black
281                $itk_component(image) configure -image $_resize \
282                    -width $w -height $h
283            } elseif {[regexp {^height=([0-9]+)$} $str match size]} {
284                set h $size
285                set w [expr {round($h*$iw/double($ih))}]
286                $_resize configure -width $w -height $h
287                $_resize blank
288                blt::winop resample $_imh $_resize box
289                _outline $_resize black
290                $itk_component(image) configure -image $_resize \
291                    -width $w -height $h
292            } else {
293                $itk_component(image) configure -image $_imh
294            }
295        }
296        auto - none - default {
297            if {[string length [label]] == 0} {
298                # old mode -- big image with no label
299                $itk_component(image) configure -image $_imh
300            } else {
301                # new mode -- thumbnail and image info
302                set w $_thumbsize
303                set h $_thumbsize
304                $itk_component(image) configure -width $w -height $h
305
306                if {$iw <= $_thumbsize && $ih <= $_thumbsize} {
307                    $_resize configure -width $iw -height $ih
308                    $_resize copy $_imh
309                    _outline $_resize black
310                } else {
311                    # large image -- scale it down
312                    if {$iw > $ih} {
313                        set h [expr {round($w/double($iw)*$ih)}]
314                    } else {
315                        set w [expr {round($h/double($ih)*$iw)}]
316                    }
317                    $_resize configure -width $w -height $h
318                    $_resize blank
319                    blt::winop resample $_imh $_resize box
320                    _outline $_resize black
321                }
322                $itk_component(image) configure -image $_resize
323            }
324        }
325    }
326}
327
328# ----------------------------------------------------------------------
329# USAGE: _outline <image> <color>
330#
331# Used internally to outline the given <image> with a single-pixel
332# line of the specified <color>.  Updates the image in place.
333# ----------------------------------------------------------------------
334itcl::body Rappture::ImageEntry::_outline {im color} {
335    if {"" != $im} {
336        set w [image width $im]
337        set h [image height $im]
338        $im put $color -to 0 0 $w 1
339        $im put $color -to 0 0 1 $h
340        $im put $color -to 0 [expr {$h-1}] $w $h
341        $im put $color -to [expr {$w-1}] 0 $w $h
342    }
343}
344
345# ----------------------------------------------------------------------
346# USAGE: _uploadValue -start
347# USAGE: _uploadValue -assign <key> <value> <key> <value> ...
348#
349# Used internally to initiate an upload operation.  Prompts the
350# user to upload into the image area of this widget.
351# ----------------------------------------------------------------------
352itcl::body Rappture::ImageEntry::_uploadValue {args} {
353    set opt [lindex $args 0]
354    switch -- $opt {
355        -start {
356            set tool [Rappture::Tool::resources -appname]
357            set cntls [list $_path [label] [tooltip]]
358            Rappture::filexfer::upload \
359                $tool $cntls [itcl::code $this _uploadValue -assign]
360        }
361        -assign {
362            array set data [lrange $args 1 end] ;# skip option
363            if {[info exists data(error)]} {
364                Rappture::Tooltip::cue $itk_component(image) $data(error)
365            }
366            if {[info exists data(data)]} {
367                Rappture::Tooltip::cue hide  ;# take down note about the popup
368                if {[catch {value $data(data)} err]} {
369                    Rappture::Tooltip::cue $itk_component(image) "Upload failed:\n$err"
370                }
371            }
372        }
373        default {
374            error "bad option \"$opt\": should be -start or -assign"
375        }
376    }
377}
378
379# ----------------------------------------------------------------------
380# USAGE: _downloadValue
381#
382# Used internally to initiate a download operation.  Takes the current
383# value and downloads it to the user in a new browser window.
384# ----------------------------------------------------------------------
385itcl::body Rappture::ImageEntry::_downloadValue {} {
386    set bytes [Rappture::encoding::decode -as b64 [$_imh data -format png]]
387    set mesg [Rappture::filexfer::download $bytes image.png]
388
389    if {"" != $mesg} {
390        Rappture::Tooltip::cue $itk_component(image) $mesg
391    }
392}
393
394# ----------------------------------------------------------------------
395# CONFIGURATION OPTION: -state
396# ----------------------------------------------------------------------
397itcl::configbody Rappture::ImageEntry::state {
398    set valid {normal disabled}
399    if {[lsearch -exact $valid $itk_option(-state)] < 0} {
400        error "bad value \"$itk_option(-state)\": should be [join $valid {, }]"
401    }
402    $itk_component(image) configure -state $itk_option(-state)
403}
Note: See TracBrowser for help on using the repository browser.