1#!/bin/sh 2# The next line restarts using wish \ 3exec wish $0 ${1+"$@"} 4 5package require msgcat 6::msgcat::mcload [file join [file dirname [info script]] msgs] 7catch {namespace import ::msgcat::mc} 8 9proc mmc string { 10 regsub & $string {} string 11 return $string 12} 13 14proc mml string { 15 return [string first & $string] 16} 17 18# 19# Make the Image format available. 20# 21 22package require Img 23 24# 25# Initialization of some global variables 26# 27 28set tkvPriv(count) 0 29set tkvPriv(currentdir) [pwd] 30set tkvPriv(defaultext) .gif 31 32set tkvPriv(types) [list \ 33 [list [mc "Image Files"] {.bmp} ] \ 34 [list [mc "Image Files"] {.gif} ] \ 35 [list [mc "Image Files"] {.jpeg .jpg} ] \ 36 [list [mc "Image Files"] {.png} ] \ 37 [list [mc "Image Files"] {.tiff .tif} ] \ 38 [list [mc "Image Files"] {.xbm} ] \ 39 [list [mc "Image Files"] {.xpm} ] \ 40 [list [mc "Image Files"] {.ps .eps} ] \ 41 [list "BMP [mc Files]" {.bmp} ] \ 42 [list "GIF [mc Files]" {.gif} ] \ 43 [list "JPEG [mc Files]" {.jpeg .jpg} ] \ 44 [list "PNG [mc Files]" {.png} ] \ 45 [list "TIFF [mc Files]" {.tiff .tif} ] \ 46 [list "XBM [mc Files]" {.xbm} ] \ 47 [list "XPM [mc Files]" {.xpm} ] \ 48 [list "Postscript [mc Files]" {.ps .eps} ] \ 49 [list "GIF [mc Files]" {} GIFF] \ 50 [list "JPEG [mc Files]" {} JPEG] \ 51 [list "PNG [mc Files]" {} PNGF] \ 52 [list "TIFF [mc Files]" {} TIFF] \ 53 [list [mc {All files}] *] \ 54] 55 56proc Menu {base name} { 57 set menu [ConCat $base menu] 58 if {![winfo exists $menu]} { 59 menu $menu 60 $base configure -menu $menu 61 } 62 set accelerator [string toupper [string index $name 0]] 63 set text [mc "&$accelerator[string range $name 1 end]"] 64 set name $menu.$name 65 if {![winfo exists $name]} { 66 menu $name 67 $menu add cascade -label [mmc $text] -menu $name -underline [mml $text] 68 } 69 return $name 70} 71 72# 73# Small proc to concatenate window pathnames 74# 75proc ConCat args { 76 regsub -all {[ \.]+} $args . args 77 return $args 78} 79 80# 81# Create a new image window 82# 83 84proc image_window {{window {}}} { 85 global tkvPriv 86 if {![string compare $window {}]} { 87 set window .image$tkvPriv(count) 88 incr tkvPriv(count) 89 } 90 if {[winfo exists $window]} { 91 catch {eval destroy [winfo children $window]} 92 } else { 93 toplevel $window 94 } 95 wm title $window [mc {Viewer}] 96 set frame [ConCat $window frame] 97 label $frame -relief sunken -bg white -bd 2 -anchor nw 98 set w [Menu $window file] 99 $w configure -tearoff 0 100 set text [mc &Open] 101 $w add command -label [mmc $text] -command [list load_image $window] -underline [mml $text] 102 set text [mc &Save] 103 $w add command -label [mmc $text] -command [list save_image $window] -underline [mml $text] 104 $w add separator 105 set text [mc &Close] 106 $w add command -label [mmc $text] -command [list destroy $window] -underline [mml $text] 107 set text [mc E&xit] 108 $w add command -label [mmc $text] -command [list destroy .] -underline [mml $text] 109 110 set w [Menu $window images] 111 set w [Menu $window help] 112 $w configure -tearoff 0 113 set text [mc &About] 114 $w add command -label [mmc $text] -command About -underline [mml $text] 115 116 catch {wm geometry $window 200x200} 117 pack $frame -side top -expand y -fill both 118 return $frame 119} 120 121proc register_image {w name} { 122 set menu [Menu $w images] 123 set item [file tail [lindex $name 0]] 124 if {[llength $name] > 1} { 125 append item " [lindex $name 1]" 126 } 127 $menu add command -label $item -command \ 128 [list show_image $w $name] 129} 130 131proc show_image {window name} { 132 [ConCat $window frame] configure -image $name 133 catch {wm geometry $window {}} 134} 135 136proc load_image window { 137 global tkvPriv 138 set filename [tk_getOpenFile -filetypes $tkvPriv(types) -parent \ 139 $window -initialdir $tkvPriv(currentdir)] 140 if {[string compare $filename {}]} { 141 set imagename [list $filename] 142 image create photo $imagename -file $filename 143 register_image $window $imagename 144 show_image $window $imagename 145 set tkvPriv(currentdir) [file dirname $filename] 146 } 147} 148 149proc save_image window { 150 global tkvPriv 151 set img [[ConCat $window frame] cget -image] 152 set filename [tk_getSaveFile -filetypes $tkvPriv(types) -parent \ 153 $window -initialdir $tkvPriv(currentdir) -defaultextension .gif \ 154 -initialfile [file rootname [lindex $img 0]].gif] 155 if {[string compare $filename {}]} { 156 $img write $filename -format gif 157 set tkvPriv(currentdir) [file dirname $filename] 158 } 159} 160 161proc About {} { 162 tk_dialog .about "[mmc [mc &About]] tkv.tcl" "[mc {Tiny Image viewer}]\n[mc {written by}]\ 163 Jan Nijtmans <nijtmans@users.sourceforge.net>" {} 0 [mc O.K.] 164} 165 166set w [lindex $argv 1] 167if {![string compare $w {}]} { 168 set w . 169} 170set filename [lindex $argv 0] 171 172image_window $w 173if {[string compare $filename {}]} { 174 set imagename [list $filename] 175 image create photo $imagename -file $filename 176 register_image $w $imagename 177 show_image $w $imagename 178} 179