source: trunk/gsascmds.tcl @ 52

Last change on this file since 52 was 52, checked in by toby, 11 years ago

# on 1999/02/16 18:03:01, toby did:
change comment

  • Property rcs:author set to toby
  • Property rcs:date set to 1999/02/16 18:03:01
  • Property rcs:lines set to +2 -1
  • Property rcs:rev set to 1.6
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 27.7 KB
Line 
1# should do some work here on convert to make the file dialog much more
2# like that in getExpFileName (propogate to tkGSAS as well?)
3
4# platform-specific code
5if {$tcl_platform(platform) == "windows"} {
6    if [catch {package require winexec}] {
7        tk_dialog .err "WINEXEC Error" \
8                "Error -- Unable to load the WINEXEC package. This is needed in Win95 machines" \
9                error 0 Quit
10        destroy .
11    }
12    if {$tcl_platform(os) == "Windows 95" || $tcl_platform(os) == "Windows 98" } {
13        # this creates a DOS box to run a program in
14        proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
15            global env expgui
16            # Windows environment variables
17            # -95 does not seem to be able to use these
18            set env(GSAS) [file nativename $expgui(gsasdir)]
19            # PGPLOT_FONT is needed by PGPLOT
20            set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
21            # this is the number of lines/page in the .LST (etc.) file
22            set env(LENPAGE) 60
23            set pwd [file nativename [pwd]]
24
25            # check the path -- can DOS use it?
26            if {[string first // [pwd]] != -1} {
27                tk_dialog .braindead "Invalid Path" \
28                {Error -- Use "Map network drive" to access this directory with a letter (e.g. F:) \
29                Win-95 can't directly access a network drive in DOS} error 0 OK
30                return
31            }
32            # all winexec commands are background commands
33            #   if $background
34
35            # pause is hard coded in the .BAT file
36            #if $wait  {
37            #   append command " pause"
38            #}
39
40            # replace the forward slashes with backward
41            regsub -all / $command \\ command
42            # Win95 does not seem to inherit the environment from Tcl env vars
43            # so define it in the .BAT file
44            winexec -d [file nativename [pwd]] \
45                [file join $expgui(scriptdir) gsastcl.bat] \
46                "[file nativename $expgui(gsasdir)] $command"
47        }
48    } else {
49        # now for - brain-dead Windows-NT
50        # this creates a DOS box to run a program in
51        proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
52            global env expgui
53            # Windows environment variables
54            # -95 does not seem to be able to use these
55            set env(GSAS) [file nativename $expgui(gsasdir)]
56            # PGPLOT_FONT is needed by PGPLOT
57            set env(PGPLOT_FONT) [file nativename [file join $expgui(gsasdir) fonts grfont.dat]]
58            # this is the number of lines/page in the .LST (etc.) file
59            set env(LENPAGE) 60
60            # all winexec commands are background commands -- ignore background arg
61
62            # can't get pause to work! -- ignore wait
63
64            set prevcmd {}
65            foreach cmd $command {
66                if {$prevcmd != ""} {
67                    tk_dialog .done_yet Confirm "Press OK to start command $cmd" "" 0 OK
68                }
69                # replace the forward slashes with backward
70                regsub -all / $cmd \\ cmd
71                # cmd.exe must be in the path -- lets hope that at least works!
72                winexec -d [file nativename [pwd]] cmd.exe "/c $cmd"
73                set prevcmd $cmd
74            }
75        }
76    }
77} else {
78    if [catch {set env(GSASBACKSPACE)}] {set env(GSASBACKSPACE) 1}
79
80    # this creates a xterm window to run a program in
81    proc forknewterm {title command "background 0" "scrollbar 1" "wait 1"} {
82        global env expgui
83        # UNIX environment variables
84        set env(GSASEXE) $expgui(gsasexe)
85        set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
86        set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
87        # PGPLOT_DIR is needed by PGPLOT
88        set env(PGPLOT_DIR) [file join $expgui(gsasdir) pgl]
89        # this is the number of lines/page in the .LST (etc.) file
90        set env(LENPAGE) 60
91        set termopts {}
92        if $env(GSASBACKSPACE) {
93            append termopts \
94                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
95        }
96        if $scrollbar {
97            append termopts " -sb"
98        } else {
99            append termopts " +sb"
100        }
101        if $background {
102            set suffix {&}
103        } else {
104            set suffix {}
105        }
106        #
107        if $wait  {
108            append command "\; echo -n Press Enter to continue \; read x"
109        }
110        if !$background {wm iconify .}
111        catch {eval exec xterm $termopts -title [list $title] \
112                -e /bin/sh -c [list $command] $suffix} errmsg
113        if $expgui(debug) {puts "xterm result = $errmsg"}
114        if !$background {wm deiconify .}
115    }
116}
117
118# get a value in a modal toplevel
119proc getstring {what "chars 40" "quit 1" "initvalue {}"} {
120    global expgui expmap
121    set w .global
122    catch {destroy $w}
123    toplevel $w -bg beige
124    wm title $w "Input $what"
125    set expgui(temp) {}
126    pack [frame $w.0 -bd 6 -relief groove -bg beige] \
127            -side top -expand yes -fill both
128    grid [label $w.0.a -text "Input a value for the $what" \
129            -bg beige] \
130            -row 0 -column 0 -columnspan 10
131    grid [entry $w.0.b -textvariable expgui(temp) -width $chars] \
132            -row 1 -column 0 
133
134    set expgui(temp) $initvalue
135    pack [frame $w.b] -side top
136    pack [button $w.b.2 -text Set -command "destroy $w"] -side left
137    if $quit {
138        pack [button $w.b.3 -text Quit \
139                -command "set expgui(temp) {}; destroy $w"] -side left
140    }
141    # force the window to stay on top
142    wm transient $w [winfo toplevel [winfo parent $w]]
143
144    bind $w <Return> "destroy $w"
145    wm withdraw $w
146    update idletasks
147    # center the new window in the middle of the parent
148    set x [expr [winfo x [winfo parent $w]] + [winfo width .]/2 - \
149            [winfo reqwidth $w]/2 - [winfo vrootx [winfo parent $w]]]
150    set y [expr [winfo y [winfo parent $w]] + [winfo height .]/2 - \
151            [winfo reqheight $w]/2 - [winfo vrooty [winfo parent $w]]]
152    wm geom $w +$x+$y
153    wm deiconify $w
154
155    set oldFocus [focus]
156    set oldGrab [grab current $w]
157    if {$oldGrab != ""} {
158        set grabStatus [grab status $oldGrab]
159    }
160    grab $w
161    focus $w.b.2
162    tkwait window $w
163    catch {focus $oldFocus}
164    if {$oldGrab != ""} {
165        if {$grabStatus == "global"} {
166            grab -global $oldGrab
167        } else {
168            grab $oldGrab
169        }
170    }
171    return $expgui(temp)
172}
173
174# run a GSAS program that does not require an experiment file
175proc runGSASprog {proglist} {
176    global expgui tcl_platform
177    set cmd {}
178    foreach prog $proglist {
179        if {$tcl_platform(platform) == "windows"} {
180            append cmd " \"$expgui(gsasexe)/${prog}.exe \" "
181        } else {
182            if {$cmd != ""} {append cmd "\;"}
183            append cmd "[file join $expgui(gsasexe) $prog]"
184        }
185    }
186    forknewterm $prog $cmd 0 1 1
187}
188
189# run a GSAS program that requires an experiment file for input/output
190proc runGSASwEXP {proglist} {
191    global expgui tcl_platform
192    # Save the current exp file
193    savearchiveexp
194    set cmd {}
195    set expnam [file root [file tail $expgui(expfile)]]
196    foreach prog $proglist {
197        if {$prog == "expedt" && $expgui(archive)} archiveexp
198        if {$tcl_platform(platform) == "windows"} {
199            append cmd " \"$expgui(gsasexe)/${prog}.exe $expnam \" "
200        } else {
201            if {$cmd != ""} {append cmd "\;"}
202            append cmd "[file join $expgui(gsasexe) $prog] $expnam"
203        }
204    }
205    forknewterm "$prog -- $expnam" $cmd 0 1 1
206    wm deiconify .
207}
208
209# run liveplot
210proc liveplot {} {
211    global expgui liveplot wishshell
212    set expnam [file root [file tail $expgui(expfile)]]
213    exec $wishshell [file join $expgui(scriptdir) liveplot] \
214            $expnam $liveplot(hst) $liveplot(legend) &
215}
216
217# run lstview
218proc lstview {} {
219    global expgui wishshell
220    set expnam [file root [file tail $expgui(expfile)]]
221    exec $wishshell [file join $expgui(scriptdir) lstview] $expnam &
222}
223
224# run widplt
225proc widplt {} {
226    global expgui wishshell
227    exec $wishshell [file join $expgui(scriptdir) widplt] \
228            $expgui(expfile) &
229}
230
231# show help information
232proc showhelp {} {
233    global expgui_helplist helpmsg
234    set helpmsg {}
235    set frm .help
236    catch {destroy $frm}
237    toplevel $frm
238    wm title $frm "Command Help"
239    pack [message $frm.0 -text \
240            "Click on an entry below to see help on a GSAS command" ] \
241            -side top
242    pack [frame $frm.a -width 20 -height 15] \
243            -side top -expand yes -fill both
244    pack [message $frm.help -textvariable helpmsg -relief groove] \
245            -side left -fill both -expand yes
246    set lst [array names expgui_helplist]
247    listbox $frm.a.cmds -relief raised -bd 2 -yscrollcommand \
248            "$frm.a.scroll set" -height 15 -width 0
249    scrollbar $frm.a.scroll -command "$frm.a.cmds yview"
250    foreach item [lsort $lst] {
251        $frm.a.cmds insert end $item 
252    }
253    if {[$frm.a.cmds curselection] == ""} {$frm.a.cmds selection set 0}
254    button $frm.a.done -text Done -command "destroy $frm"
255    bind $frm.a.cmds <ButtonRelease-1> \
256            "+set helpmsg \$expgui_helplist(\[$frm.a.cmds get \[$frm.a.cmds curselection\]\])"
257    pack $frm.a.scroll -side left -fill y
258    pack $frm.a.cmds -side left -expand yes -anchor w
259    pack $frm.a.done -side right -expand no
260    # get the size of the window and expand the message boxes to match
261    update
262    set width [lindex [split [wm geometry $frm] x+] 0]
263    $frm.0 config -width $width
264    $frm.help config -width $width
265    # waitdone $frm
266}
267
268# convert a file
269proc convfile {} {
270    global tcl_platform
271    if {$tcl_platform(platform) == "windows"} {
272        convwin
273    } else {
274        convunix
275    }
276}
277
278# file conversions for UNIX (convstod convdtos)
279proc convunix {} {
280    global expgui infile outfile
281    set frm .file
282    catch {destroy $frm}
283    toplevel $frm
284    wm title $frm "Convert File"
285    pack [frame [set frm0 $frm.0] -bd 2 -relief groove] -padx 3 -pady 3 -side top
286    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
287    pack [frame [set frmB $frm.2] -bd 2 -relief groove] -padx 3 -pady 3 -side left
288    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
289    pack [button $frmC.b -text Convert -command "valid_conv_file"] -side top
290    pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side top
291
292    pack [label $frmA.0 -text "Select an input file"] -side top -anchor center
293    pack [label $frmB.0 -text "Enter an output file"] -side top -anchor center
294   
295    pack [label $frm0.1 -text "Convert to:"] -side top -anchor w
296    pack [radiobutton $frm0.2 -text "direct access" -value convstod \
297            -command setoutfile \
298            -variable outfile(type)] -side top -anchor w
299    pack [radiobutton $frm0.3 -text "sequential" -value convdtos \
300            -command setoutfile \
301            -variable outfile(type)] -side top -anchor w
302    set outfile(type) ""
303    cnvfilebox $frmA infile 1 
304    cnvfilebox $frmB outfile 0 
305    set infile(done) 0
306    # force the window to stay on top
307    wm transient $frm [winfo toplevel [winfo parent $frm]]
308
309    bind $frm <Return> "valid_conv_file"
310    wm withdraw $frm
311    update idletasks
312    # center the new window in the middle of the parent
313    set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \
314            [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]]
315    set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \
316            [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]]
317    wm geom $frm +$x+$y
318    wm deiconify $frm
319
320    set oldFocus [focus]
321    set oldGrab [grab current $frm]
322    if {$oldGrab != ""} {
323        set grabStatus [grab status $oldGrab]
324    }
325    grab $frm
326    focus $frmC.q 
327    update
328    tkwait variable infile(done)
329    catch {focus $oldFocus}
330    if {$oldGrab != ""} {
331        if {$grabStatus == "global"} {
332            grab -global $oldGrab
333        } else {
334            grab $oldGrab
335        }
336    }
337    destroy $frm
338}
339
340# validate the files and make the conversion
341proc valid_conv_file {} {
342    global infile outfile expgui
343    if {$outfile(type) == "convstod" || $outfile(type) == "convdtos"} {
344        set convtype $outfile(type)
345    } else {
346        return
347    }
348    if {$infile(name) == ""} return
349    if {$outfile(name) == ""} return
350    if {$infile(name) == $outfile(name)} {
351        tk_dialog .warn Notify "Sorry, filenames must differ" warning 0 OK
352        return
353    }
354    if ![file exists [file join $infile(dir) $infile(name)]] {
355        tk_dialog .warn Notify \
356                "Sorry, file $infile(name) not found in $infile(dir)" warning 0 OK
357        return
358    }
359    if [file exists [file join $outfile(dir) $outfile(name)]] {
360        if [tk_dialog .warn Notify \
361                "Warning: file $outfile(name) exists in $outfile(dir). OK to overwrite?" \
362                warning 0 OK No] return
363    }
364    if [catch {
365        exec [file join $expgui(gsasexe) $convtype] < \
366                [file join $infile(dir) $infile(name)] > \
367                [file join $outfile(dir) $outfile(name)]
368    } errmsg] {
369        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
370    } else {
371        if [tk_dialog .converted Notify \
372                "File converted. Convert more files?" \
373                ""  0 Yes No] {set infile(done) 1}
374    }
375}
376
377# file conversions for Windows
378proc convwin {} {
379    global expgui infile outfile
380    set frm .file
381    catch {destroy $frm}
382    toplevel $frm
383    wm title $frm "Convert File"
384    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
385    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
386    pack [button $frmC.b -text Convert -command "valid_conv_win"] -side top
387    pack [button $frmC.q -text Quit -command "set infile(done) 1"] -side top
388    pack [label $frmA.0 -text "Select a file to convert"] -side top -anchor center
389    cnvfilebox $frmA outfile 1
390    set infile(done) 0
391    # force the window to stay on top
392    wm transient $frm [winfo toplevel [winfo parent $frm]]
393
394    bind $frm <Return> "valid_conv_file"
395    wm withdraw $frm
396    update idletasks
397    # center the new window in the middle of the parent
398    set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \
399            [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]]
400    set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \
401            [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]]
402    wm geom $frm +$x+$y
403    wm deiconify $frm
404
405    set oldFocus [focus]
406    set oldGrab [grab current $frm]
407    if {$oldGrab != ""} {
408        set grabStatus [grab status $oldGrab]
409    }
410    grab $frm
411    focus $frmC.q 
412    update
413    tkwait variable infile(done)
414    if {$oldGrab != ""} {
415        if {$grabStatus == "global"} {
416            grab -global $oldGrab
417        } else {
418            grab $oldGrab
419        }
420    }
421    destroy $frm
422}
423
424# validate the files and make the conversion
425proc valid_conv_win {} {
426    global infile outfile expgui
427    if {$outfile(name) == ""} return
428    if ![file exists $outfile(dir)/$outfile(name)] {
429        tk_dialog .warn Notify \
430                "Sorry, file $outfile(name) not found in $outfile(dir)" warning 0 OK
431        return
432    }
433    if [catch {
434        set newname "[file rootname $outfile(name)].tmp"
435        set oldname "[file rootname $outfile(name)].seq"
436        set in [open $outfile(dir)/$outfile(name) r]
437        set out [open $outfile(dir)/$newname w]
438        set len [gets $in line]
439        if {$len > 160} {
440            # this is a UNIX file. Hope there are no control characters
441            set i 0
442            set j 79
443            while {$j < $len} {
444                puts $out [string range $line $i $j]
445                incr i 80
446                incr j 80
447            }
448        } else {
449            while {$len >= 0} {
450                append line "                                        "
451                append line "                                        "
452                set line [string range $line 0 79]
453                puts $out $line
454                set len [gets $in line]
455            }
456        }
457        close $in
458        close $out
459        file rename $outfile(dir)/$outfile(name) $oldname
460        file rename $newname $outfile(dir)/$outfile(name)
461    } errmsg] {
462        tk_dialog .warn Notify "Error in conversion:\n$errmsg" warning 0 OK
463    } else {
464        if [tk_dialog .converted Notify \
465                "File converted. Convert more files?" \
466                ""  0 Yes No] {set infile(done) 1}
467    }
468}
469
470# create a file box for conversions
471proc cnvfilebox {bx filvar diropt} {
472    global ${filvar}
473    pack [label $bx.d -textvariable ${filvar}(dir) -bd 2 -relief raised ] -side top
474    set ${filvar}(dir) [pwd]
475    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
476    listbox $bx.a.files -relief raised -bd 2 -yscrollcommand "$bx.a.scroll set" \
477            -height 15 -width 0
478    scrollbar $bx.a.scroll -command "$bx.a.files yview"
479    filchoose $bx $bx.a.files $filvar $diropt
480    if {$filvar == "infile"} {
481        bind $bx.a.files <ButtonRelease-1> \
482                "filchoose $bx $bx.a.files $filvar $diropt; setoutfile"
483    } else {
484        bind $bx.a.files <ButtonRelease-1> \
485                "filchoose $bx $bx.a.files $filvar $diropt"
486    }
487    pack $bx.a.scroll -side left -fill y
488    pack $bx.a.files -side left -fill both -expand yes
489    pack [entry $bx.c -textvariable ${filvar}(name)] -side top
490}
491
492# select a file or directory, also called when box is created to fill it
493proc filchoose {frm box filvar {dironly 1}} {
494    global $filvar
495    set select [$box curselection]
496    if {$select == ""} {
497        set file .
498    } else {
499        set file [string trim [$box get $select]]
500    }
501    if [file isdirectory [file join [set ${filvar}(dir)] $file]] {
502        if {$file == ".."} {
503            set ${filvar}(dir) [file dirname [set ${filvar}(dir)] ]
504        } elseif {$file != "."} {
505            set ${filvar}(dir) [file join [set ${filvar}(dir)] $file]
506        }
507        set ${filvar}(name) {}
508        $box delete 0 end
509        $box insert end {..   }
510        foreach file [lsort [glob -nocomplain \
511                [file join [set ${filvar}(dir)] *] ] ] {
512            if {[file isdirectory $file]} {
513                # is this / needed here? Does it cause a problem in MacGSAS?
514                $box insert end [file tail $file]/
515            } elseif {$dironly == 1} {
516                $box insert end [file tail $file]
517            } elseif {$dironly == 2 && [file extension $file] == ".EXP"} {
518                $box insert end [file tail $file]
519            }
520        }
521        return
522    }
523    set ${filvar}(name) [file tail $file]
524}
525
526# set new file name from old -- used for convert
527proc setoutfile {} {
528    global infile outfile
529    if {$outfile(type) == "convstod"} {
530        set lfile [string toupper $infile(name)]
531    } elseif {$outfile(type) == "convdtos"} {
532        set lfile [string tolower $infile(name)]
533    } else {
534        set lfile ""
535    }
536    if {$infile(name) == $lfile} {
537        set outfile(name) {}
538    } else {
539        set outfile(name) $lfile
540    }
541}
542
543# set options for liveplot
544proc liveplotopt {} {
545    global liveplot
546    set frm .file
547    catch {destroy $frm}
548    toplevel $frm
549    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
550    pack [scale  $frmA.1 -label "Histogram number" -from 1 -to 9 \
551            -length  150 -orient horizontal -variable liveplot(hst)] -side top
552    pack [checkbutton $frmA.2 -text {include plot legend}\
553            -variable liveplot(legend)] -side top
554    pack [button $frm.2 -text OK \
555            -command {if ![catch {expr $liveplot(hst)}] "destroy .file"} \
556            ] -side top
557    bind $frm <Return> {if ![catch {expr $liveplot(hst)}] "destroy .file"}
558    # force the window to stay on top
559    wm transient $frm [winfo toplevel [winfo parent $frm]]
560    wm withdraw $frm
561    update idletasks
562    # center the new window in the middle of the parent
563    set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \
564            [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]]
565    set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \
566            [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]]
567    wm geom $frm +$x+$y
568    wm deiconify $frm
569
570    set oldFocus [focus]
571    set oldGrab [grab current $frm]
572    if {$oldGrab != ""} {
573        set grabStatus [grab status $oldGrab]
574    }
575    grab $frm
576    focus $frm.2
577    tkwait window $frm
578    catch {focus $oldFocus}
579    if {$oldGrab != ""} {
580        if {$grabStatus == "global"} {
581            grab -global $oldGrab
582        } else {
583            grab $oldGrab
584        }
585    }
586}
587
588#------------------------------------------------------------------------------
589# get an experiment file name
590#------------------------------------------------------------------------------
591proc getExpFileName {mode} {
592    global expgui
593    set frm .file
594    catch {destroy $frm}
595    toplevel $frm
596    pack [frame [set frmA $frm.1] -bd 2 -relief groove] -padx 3 -pady 3 -side left
597    pack [frame [set frmC $frm.3] ] -padx 3 -pady 3 -side left
598    pack [label $frmC.2 -text "Sort .EXP files by" ] -side top
599    pack [radiobutton $frmC.1 -text "File Name" -value 1 \
600            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
601    pack [radiobutton $frmC.0 -text "Mod. Date" -value 0 \
602            -variable expgui(filesort) -command "ChooseExpFil $frmA"] -side top
603    pack [button $frmC.b -text Read \
604            -command "valid_exp_file $frmA $mode"] -side top
605    if {$mode == "new"} {
606        $frmC.b config -text Save
607    }
608    pack [button $frmC.q -text Quit \
609            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side top
610    bind $frm <Return> "$frmC.b invoke"
611
612    if {$mode == "new"} {
613        pack [label $frmA.0 -text "Enter an experiment file to create"] \
614                -side top -anchor center
615    } else {
616        pack [label $frmA.0 -text "Select an experiment file to read"] \
617                -side top -anchor center
618    }
619    expfilebox $frmA $mode
620    # force the window to stay on top
621    wm transient $frm [winfo toplevel [winfo parent $frm]]
622
623    wm withdraw $frm
624    update idletasks
625    # center the new window in the middle of the parent
626    set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \
627            [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]]
628    set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \
629            [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]]
630    wm geom $frm +$x+$y
631    wm deiconify $frm
632
633    set oldFocus [focus]
634    set oldGrab [grab current $frm]
635    if {$oldGrab != ""} {
636        set grabStatus [grab status $oldGrab]
637    }
638    grab $frm
639    focus $frmC.b
640    tkwait window $frm
641    catch {focus $oldFocus}
642    if {$oldGrab != ""} {
643        if {$grabStatus == "global"} {
644            grab -global $oldGrab
645        } else {
646            grab $oldGrab
647        }
648    }
649    if {$expgui(FileMenuEXPNAM) == ""} return
650    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
651}
652
653# validation routine
654proc valid_exp_file {frm mode} {
655    global expgui
656    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
657        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
658        ChooseExpFil $frm
659        return
660    } elseif [file isdirectory \
661            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
662        if {$expgui(FileMenuEXPNAM) != "."} {
663            set expgui(FileMenuDir) \
664                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
665        }
666        ChooseExpFil $frm
667        return
668    }
669    set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
670    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
671        append expgui(FileMenuEXPNAM) ".EXP"
672    }
673    if {[file extension $expgui(FileMenuEXPNAM)] != ".EXP"} {
674        tk_dialog .expFileErrorMsg "File Open Error" \
675            "File $expgui(FileMenuEXPNAM) is not a valid name. Experiment files must end in \".EXP\"" \
676            error 0 OK
677        return
678    }
679    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
680    if {$mode == "new" && [file exists $file]} {
681        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
682            "File $file already exists. OK to overwrite?" question 0 \
683             "Select other name" "Overwrite"]
684        if $ans {destroy .file}
685        return
686    }
687    if {$mode == "old" && ![file exists $file]} {
688        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
689            "File $file does not exist. OK to create?" question 0 \
690             "Select other name" "Create"]
691        if $ans {destroy .file}
692        return
693    }
694    destroy .file
695}
696
697proc updir {} {
698    global expgui
699    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
700}
701
702# create a file box
703proc expfilebox {bx mode} {
704    global expgui
705    pack [frame $bx.top] -side top
706    pack [label $bx.top.a -text "Directory" ] -side left
707    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
708    pack $bx.top.d -side left
709    set expgui(FileMenuDir) [pwd]
710    # the icon below is from tk8.0/tkfbox.tcl
711    set upfolder [image create bitmap -data {
712#define updir_width 28
713#define updir_height 16
714static char updir_bits[] = {
715   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
716   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
717   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
718   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
719   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
720   0xf0, 0xff, 0xff, 0x01};}]
721
722    pack [button $bx.top.b -image $upfolder \
723            -command "updir; ChooseExpFil $bx" ]
724    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
725    listbox $bx.a.files -relief raised -bd 2 \
726            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
727            -height 15 -width 0
728    listbox $bx.a.dates -relief raised -bd 2 \
729            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
730            -height 15 -width 0 -takefocus 0
731    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
732    ChooseExpFil $bx
733    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
734    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
735    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
736    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
737    pack $bx.a.scroll -side left -fill y
738    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
739    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
740}
741proc sync2boxes {master slave scroll args} {
742    $slave yview moveto [lindex [$master yview] 0]
743    eval $scroll set $args
744}
745proc move2boxesY {boxlist args} {
746    foreach listbox $boxlist { 
747        eval $listbox yview $args
748    }
749}
750
751# set the box or file in the selection window
752proc ReleaseExpFil {frm} {
753    global expgui
754    set files $frm.a.files
755    set dates $frm.a.dates
756    set select [$files curselection]
757    if {$select == ""} {
758        set select [$dates curselection]
759    }
760    if {$select == ""} {
761        set expgui(FileMenuEXPNAM) ""
762    } else {
763        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
764    }
765    return
766}
767
768# select a file or directory -- called on double click
769proc SelectExpFil {frm mode} {
770    global expgui
771    set files $frm.a.files
772    set dates $frm.a.dates
773    set select [$files curselection]
774    if {$select == ""} {
775        set select [$dates curselection]
776    }
777    if {$select == ""} {
778        set file .
779    } else {
780        set file [string trim [$files get $select]]
781    }
782    if {$file == "<Parent>"} {
783        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
784        ChooseExpFil $frm
785    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
786        if {$file != "."} {
787            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
788            ChooseExpFil $frm
789        }
790    } else {
791        set expgui(FileMenuEXPNAM) [file tail $file]
792        valid_exp_file $frm $mode
793    }
794}
795
796# fill the files & dates & Directory selection box with current directory,
797# also called when box is created to fill it
798proc ChooseExpFil {frm} {
799    global expgui
800    set files $frm.a.files
801    set dates $frm.a.dates
802    set expgui(FileMenuEXPNAM) {}
803    $files delete 0 end
804    $dates delete 0 end
805    $files insert end {<Parent>}
806    $dates insert end {(Directory)}
807    set filelist [glob -nocomplain \
808            [file join [set expgui(FileMenuDir)] *] ]
809    foreach file [lsort $filelist] {
810        if {[file isdirectory $file]} {
811            $files insert end [file tail $file]
812            $dates insert end {(Directory)}
813        }
814    }
815    set pairlist {}
816    foreach file [lsort $filelist] {
817        if {![file isdirectory $file]  && \
818                [string toupper [file extension $file]] == ".EXP"} {
819            set modified [file mtime $file]
820            lappend pairlist "$file $modified"
821        }
822    }
823    if {$expgui(filesort) == 0} {
824        foreach pair [lsort -index 1 -integer $pairlist] {
825            set file [lindex $pair 0]
826            set modified [clock format [lindex $pair 1] -format "%T %D"]
827            $files insert end [file tail $file]
828            $dates insert end $modified
829        }
830    } else {
831        foreach pair [lsort -index 0 $pairlist] {
832            set file [lindex $pair 0]
833            set modified [clock format [lindex $pair 1] -format "%T %D"]
834            $files insert end [file tail $file]
835            $dates insert end $modified
836        }
837    }
838    $expgui(FileDirButtonMenu)  delete 0 end
839    set list ""
840    set dir ""
841    foreach subdir [file split [set expgui(FileMenuDir)]] {
842        set dir [file join $dir $subdir]
843        lappend list $dir
844    }
845    foreach path $list {
846        $expgui(FileDirButtonMenu) add command -label $path \
847                -command "[list set expgui(FileMenuDir) $path]; \
848                ChooseExpFil $frm"
849    }
850    # highlight the current experiment -- if present
851    for {set i 0} {$i < [$files size]} {incr i} {
852        set file [$files get $i]
853        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
854            $files selection set $i
855        }
856    }
857    return
858}
859
Note: See TracBrowser for help on using the repository browser.