#!/bin/sh # The next line restarts using wish \ exec wish $0 ${1+"$@"} package require msgcat ::msgcat::mcload [file join [file dirname [info script]] msgs] catch {namespace import ::msgcat::mc} # # Make the Image format available. # set rundir [file dirname [info script]] set auto_path "[list $rundir] $auto_path" package require img::raw package require img::dted set img_version [package require Img] wm title . [mc {Tests for available image formats}] eval destroy [winfo children .] eval image delete [image names] bind . exit frame .f frame .img pack .f .img -side top -expand true -fill x button .f.v -text [mc Viewer] -command start_viewer pack .f.v -side left -expand true -fill y button .f.b -text [mc "More tests"] -command run_more_tests pack .f.b -side right -expand true -fill y message .f.m -aspect 1000 -text [format [mc "This page shows the available\ image formats of the Img extension (version %s, using Tcl/Tk %s)"] $img_version $tcl_patchLevel] pack .f.m -side left -expand true -fill x proc run_more_tests {} { global rundir if {[winfo exists .t]} { raise .t } else { toplevel .t wm title .t [mc {More tests}] frame .t.f button .t.f.d -text [mc Dismiss] -command [list destroy .t] pack .t.f.d -side left pack .t.f -side top -fill x text .t.t -yscrollcommand [list .t.s set] scrollbar .t.s -command [list .t.t yview] pack .t.t .t.s -side left -expand y -fill both } .t.t delete 1.0 end .t.t insert end "-------- [mc {starting tests}] --------\n" set olddir [pwd] cd [file join $rundir tests] proc puts args { .t.t insert end "[lindex $args 1]\n" .t.t see end update } set result [catch {uplevel #0 source all}] cd $olddir if $result return .t.t insert end "-------- [mc {end of tests}] --------\n" if {[package vcompare [info tclversion] 8.3]<0} { .t.t insert end { note: if the previous tests fail, and you are using Tcl/Tk 8.2.X or lower, the cause is that Tk doesn't handle transparency correctly. If you don't mind transparency, all else should be well. } } .t.t see end } proc start_viewer {} { global tkvPriv rundir set argv {{} .viewer} source [file join $rundir tkv.tcl] foreach i [lsort [image names]] { register_image .viewer $i } } set curRow 1 set curCol 0 grid columnconfigure .img 1 -weight 1 proc update_animated_gif {w option num} { global imgPriv if {[info exists imgPriv($w,args)]} { set im [image create photo "${w}_[expr $num+1]"] $im copy $imgPriv($w,$num) incr num if {[catch "$im configure $imgPriv($w,args) -format \{gif -index $num\}"]} { unset imgPriv($w,args) if {$num>1} { set num 0 set im $imgPriv($w,$num) } else { # this is not an animated GIF; just stop unset imgPriv($w,0) return } } else { $im configure -data {} -file {};#free storage set imgPriv($w,$num) $im } } else { incr num if {![info exists imgPriv($w,$num)]} { set num 0 } set im $imgPriv($w,$num) } if {[catch "$w $option $im"]} { catch {unset imgPriv($w,args)} foreach im [array names imgPriv $w,*] { image delete $imgPriv($im) unset imgPriv($im) } } else { update idletasks after 20 [list update_animated_gif $w $option $num] } } proc show_animated_gif {w args} { global imgPriv catch {destroy $w} label $w if {[catch "image create photo ${w}_0 $args -format \{gif -index 0\}" image]} { $w configure -text [mc "error displaying animated gif"]:\n$image" \ -relief ridge } else { $image configure -data {} -file {} -format {};# free storage $w configure -image $image set imgPriv($w,0) $image set imgPriv($w,args) $args update idletasks after 20 [list update_animated_gif $w {configure -image} 0] } grid $w -row 0 -column 0 -columnspan 4 -sticky ew toolhelpAddBinding $w "Animated GIF" return $w } proc toolhelpInit { w { bgColor yellow } { fgColor black } } { global topWidget # Create Toolbar help window with a simple label in it. if { [winfo exists $w] } { destroy $w } toplevel $w set topWidget $w label $w.l -text "This is toolhelp" -bg $bgColor -fg $fgColor -relief ridge pack $w.l wm overrideredirect $w true catch { ::tk::unsupported::MacWindowStyle style $w help none } wm geometry $w [format "+%d+%d" -100 -100] } proc toolhelpShow { x y str } { global topWidget $topWidget.l configure -text $str raise $topWidget wm geometry $topWidget [format "+%d+%d" $x [expr $y +10]] } proc toolhelpHide {} { global topWidget wm geometry $topWidget [format "+%d+%d" -100 -100] } proc toolhelpAddBinding { w str } { global topWidget if { ![info exists topWidget]} { toolhelpInit .poToolhelp } bind $w "toolhelpShow %X %Y [list $str]" bind $w "toolhelpHide" bind $w