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

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