source: trunk/gsascmds.tcl @ 29

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

# on 1999/01/20 19:27:48, toby did:
use custom file open box; fix GSAS env definition on -95 and -NT

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