source: trunk/gsascmds.tcl @ 38

Last change on this file since 38 was 32, checked in by toby, 14 years ago

# on 1999/01/20 20:19:58, toby did:
change labels on .EXP select menu
  • Property rcs:author set to toby
  • Property rcs:date set to 1999/01/20 20:19:58
  • Property rcs:lines set to +11 -2
  • Property rcs:rev set to 1.4
  • Property rcs:state set to Exp
  • Property svn:keywords set to Author Date Revision Id
File size: 27.6 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 Read \
603            -command "valid_exp_file $frmA $mode"] -side top
604    if {$mode == "new"} {
605        $frmC.b config -text Save
606    }
607    pack [button $frmC.q -text Quit \
608            -command "set expgui(FileMenuEXPNAM) {}; destroy $frm"] -side top
609    bind $frm <Return> "$frmC.b invoke"
610
611    if {$mode == "new"} {
612        pack [label $frmA.0 -text "Enter an experiment file to create"] \
613                -side top -anchor center
614    } else {
615        pack [label $frmA.0 -text "Select an experiment file to read"] \
616                -side top -anchor center
617    }
618    expfilebox $frmA $mode
619    # force the window to stay on top
620    wm transient $frm [winfo toplevel [winfo parent $frm]]
621
622    wm withdraw $frm
623    update idletasks
624    # center the new window in the middle of the parent
625    set x [expr [winfo x [winfo parent $frm]] + [winfo width .]/2 - \
626            [winfo reqwidth $frm]/2 - [winfo vrootx [winfo parent $frm]]]
627    set y [expr [winfo y [winfo parent $frm]] + [winfo height .]/2 - \
628            [winfo reqheight $frm]/2 - [winfo vrooty [winfo parent $frm]]]
629    wm geom $frm +$x+$y
630    wm deiconify $frm
631
632    set oldFocus [focus]
633    set oldGrab [grab current $frm]
634    if {$oldGrab != ""} {
635        set grabStatus [grab status $oldGrab]
636    }
637    grab $frm
638    focus $frmC.b
639    tkwait window $frm
640    catch {focus $oldFocus}
641    if {$oldGrab != ""} {
642        if {$grabStatus == "global"} {
643            grab -global $oldGrab
644        } else {
645            grab $oldGrab
646        }
647    }
648    if {$expgui(FileMenuEXPNAM) == ""} return
649    return [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
650}
651
652# validation routine
653proc valid_exp_file {frm mode} {
654    global expgui
655    if {$expgui(FileMenuEXPNAM) == "<Parent>"} {
656        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
657        ChooseExpFil $frm
658        return
659    } elseif [file isdirectory \
660            [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]] {
661        if {$expgui(FileMenuEXPNAM) != "."} {
662            set expgui(FileMenuDir) \
663                [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
664        }
665        ChooseExpFil $frm
666        return
667    }
668    set expgui(FileMenuEXPNAM) [string toupper $expgui(FileMenuEXPNAM)]
669    if {[file extension $expgui(FileMenuEXPNAM)] == ""} {
670        append expgui(FileMenuEXPNAM) ".EXP"
671    }
672    if {[file extension $expgui(FileMenuEXPNAM)] != ".EXP"} {
673        tk_dialog .expFileErrorMsg "File Open Error" \
674            "File $expgui(FileMenuEXPNAM) is not a valid name. Experiment files must end in \".EXP\"" \
675            error 0 OK
676        return
677    }
678    set file [file join $expgui(FileMenuDir) $expgui(FileMenuEXPNAM)]
679    if {$mode == "new" && [file exists $file]} {
680        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
681            "File $file already exists. OK to overwrite?" question 0 \
682             "Select other name" "Overwrite"]
683        if $ans {destroy .file}
684        return
685    }
686    if {$mode == "old" && ![file exists $file]} {
687        set ans [tk_dialog .expFileErrorMsg "File Open Error" \
688            "File $file does not exist. OK to create?" question 0 \
689             "Select other name" "Create"]
690        if $ans {destroy .file}
691        return
692    }
693    destroy .file
694}
695
696proc updir {} {
697    global expgui
698    set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)]]
699}
700
701# create a file box
702proc expfilebox {bx mode} {
703    global expgui
704    pack [frame $bx.top] -side top
705    pack [label $bx.top.a -text "Directory" ] -side left
706    set expgui(FileDirButtonMenu) [tk_optionMenu $bx.top.d expgui(FileMenuDir) [pwd] ]
707    pack $bx.top.d -side left
708    set expgui(FileMenuDir) [pwd]
709    # the icon below is from tk8.0/tkfbox.tcl
710    set upfolder [image create bitmap -data {
711#define updir_width 28
712#define updir_height 16
713static char updir_bits[] = {
714   0x00, 0x00, 0x00, 0x00, 0x80, 0x1f, 0x00, 0x00, 0x40, 0x20, 0x00, 0x00,
715   0x20, 0x40, 0x00, 0x00, 0xf0, 0xff, 0xff, 0x01, 0x10, 0x00, 0x00, 0x01,
716   0x10, 0x02, 0x00, 0x01, 0x10, 0x07, 0x00, 0x01, 0x90, 0x0f, 0x00, 0x01,
717   0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01, 0x10, 0x02, 0x00, 0x01,
718   0x10, 0xfe, 0x07, 0x01, 0x10, 0x00, 0x00, 0x01, 0x10, 0x00, 0x00, 0x01,
719   0xf0, 0xff, 0xff, 0x01};}]
720
721    pack [button $bx.top.b -image $upfolder \
722            -command "updir; ChooseExpFil $bx" ]
723    pack [frame $bx.a -width 200 -height 75] -side top -expand yes -fill both
724    listbox $bx.a.files -relief raised -bd 2 \
725            -yscrollcommand "sync2boxes $bx.a.files $bx.a.dates $bx.a.scroll" \
726            -height 15 -width 0
727    listbox $bx.a.dates -relief raised -bd 2 \
728            -yscrollcommand "sync2boxes $bx.a.dates $bx.a.files $bx.a.scroll" \
729            -height 15 -width 0 -takefocus 0
730    scrollbar $bx.a.scroll -command "move2boxesY \" $bx.a.files $bx.a.dates \" "
731    ChooseExpFil $bx
732    bind $bx.a.files <ButtonRelease-1> "ReleaseExpFil $bx"
733    bind $bx.a.dates <ButtonRelease-1> "ReleaseExpFil $bx"
734    bind $bx.a.files <Double-1> "SelectExpFil $bx $mode"
735    bind $bx.a.dates <Double-1> "SelectExpFil $bx $mode"
736    pack $bx.a.scroll -side left -fill y
737    pack $bx.a.files $bx.a.dates -side left -fill both -expand yes
738    pack [entry $bx.c -textvariable expgui(FileMenuEXPNAM)] -side top
739}
740proc sync2boxes {master slave scroll args} {
741    $slave yview moveto [lindex [$master yview] 0]
742    eval $scroll set $args
743}
744proc move2boxesY {boxlist args} {
745    foreach listbox $boxlist { 
746        eval $listbox yview $args
747    }
748}
749
750# set the box or file in the selection window
751proc ReleaseExpFil {frm} {
752    global expgui
753    set files $frm.a.files
754    set dates $frm.a.dates
755    set select [$files curselection]
756    if {$select == ""} {
757        set select [$dates curselection]
758    }
759    if {$select == ""} {
760        set expgui(FileMenuEXPNAM) ""
761    } else {
762        set expgui(FileMenuEXPNAM) [string trim [$files get $select]]
763    }
764    return
765}
766
767# select a file or directory -- called on double click
768proc SelectExpFil {frm mode} {
769    global expgui
770    set files $frm.a.files
771    set dates $frm.a.dates
772    set select [$files curselection]
773    if {$select == ""} {
774        set select [$dates curselection]
775    }
776    if {$select == ""} {
777        set file .
778    } else {
779        set file [string trim [$files get $select]]
780    }
781    if {$file == "<Parent>"} {
782        set expgui(FileMenuDir) [file dirname [set expgui(FileMenuDir)] ]
783        ChooseExpFil $frm
784    } elseif [file isdirectory [file join [set expgui(FileMenuDir)] $file]] {
785        if {$file != "."} {
786            set expgui(FileMenuDir) [file join [set expgui(FileMenuDir)] $file]
787            ChooseExpFil $frm
788        }
789    } else {
790        set expgui(FileMenuEXPNAM) [file tail $file]
791        valid_exp_file $frm $mode
792    }
793}
794
795# fill the files & dates & Directory selection box with current directory,
796# also called when box is created to fill it
797proc ChooseExpFil {frm} {
798    global expgui
799    set files $frm.a.files
800    set dates $frm.a.dates
801    set expgui(FileMenuEXPNAM) {}
802    $files delete 0 end
803    $dates delete 0 end
804    $files insert end {<Parent>}
805    $dates insert end {(Directory)}
806    set filelist [glob -nocomplain \
807            [file join [set expgui(FileMenuDir)] *] ]
808    foreach file [lsort $filelist] {
809        if {[file isdirectory $file]} {
810            $files insert end [file tail $file]
811            $dates insert end {(Directory)}
812        }
813    }
814    set pairlist {}
815    foreach file [lsort $filelist] {
816        if {![file isdirectory $file]  && \
817                [file extension $file] == ".EXP"} {
818            set modified [file mtime $file]
819            lappend pairlist "$file $modified"
820        }
821    }
822    if {$expgui(filesort) == 0} {
823        foreach pair [lsort -index 1 -integer $pairlist] {
824            set file [lindex $pair 0]
825            set modified [clock format [lindex $pair 1] -format "%T %D"]
826            $files insert end [file tail $file]
827            $dates insert end $modified
828        }
829    } else {
830        foreach pair [lsort -index 0 $pairlist] {
831            set file [lindex $pair 0]
832            set modified [clock format [lindex $pair 1] -format "%T %D"]
833            $files insert end [file tail $file]
834            $dates insert end $modified
835        }
836    }
837    $expgui(FileDirButtonMenu)  delete 0 end
838    set list ""
839    set dir ""
840    foreach subdir [file split [set expgui(FileMenuDir)]] {
841        set dir [file join $dir $subdir]
842        lappend list $dir
843    }
844    foreach path $list {
845        $expgui(FileDirButtonMenu) add command -label $path \
846                -command "[list set expgui(FileMenuDir) $path]; \
847                ChooseExpFil $frm"
848    }
849    # highlight the current experiment -- if present
850    for {set i 0} {$i < [$files size]} {incr i} {
851        set file [$files get $i]
852        if {$expgui(expfile) == [file join $expgui(FileMenuDir) $file]} {
853            $files selection set $i
854        }
855    }
856    return
857}
858
Note: See TracBrowser for help on using the repository browser.