/[ascend]/trunk/ascend4/TK/UtilProc.tcl
ViewVC logotype

Contents of /trunk/ascend4/TK/UtilProc.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download) (as text)
Fri Oct 29 20:54:12 2004 UTC (15 years, 3 months ago) by aw0a
File MIME type: text/x-tcl
File size: 20263 byte(s)
Setting up web subdirectory in repository
1 # UtilProc.tcl: ascend path/unix utility box procedures
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.38 $
6 # Last modified on: $Date: 1998/06/18 15:55:07 $
7 # Last modified by: $Author: mthomas $
8 # Revision control file: $RCSfile: UtilProc.tcl,v $
9 #
10 # This file is part of the ASCEND Tcl/Tk Interface.
11 #
12 # Copyright (C) 1994-1998 Carnegie Mellon University
13 #
14 # The ASCEND Tcl/Tk Interface is free software; you can redistribute
15 # it and/or modify it under the terms of the GNU General Public
16 # License as published by the Free Software Foundation; either
17 # version 2 of the License, or (at your option) any later version.
18 #
19 # The ASCEND Tcl/Tk Interface is distributed in hope that it will be
20 # useful, but WITHOUT ANY WARRANTY; without even the implied warranty
21 # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
23 #
24 # You should have received a copy of the GNU General Public License
25 # along with the program; if not, write to the Free Software
26 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
27 # file named COPYING. COPYING is found in ../compiler.
28
29 #------------------------------------------------------------------------
30 # each system default not configured by
31 # Xresources or ascend.ad should have an entry in the ascUtilVect
32 # The list of subscripts is keyed to the list of labels through
33 # the util_get_label procedure so we don't actually have to
34 # add new widget definitions every time we get a new utility:
35 # just update the procedures
36 # util_init
37 # util_get_label
38 # util_get_var
39 #
40 # display is alpha-by-utilvect-subscript order
41 # any sanity checking desired must be done at button press time
42 #
43 # util init:creates a utilvect entry for each option we want to appear
44 # on the unix page. the values in sub must be appropriate as array
45 # subscripts, duh, and widget names.
46 #
47
48 # Work around for tcl's braindead file volume command which
49 # demands media in every drive before returning.
50 # This simply gets the list of lettered devices c-z: that exist
51 proc windoze_file_volume {} {
52 set result {}
53 foreach i {c d e f g h i j k l m n o p q r s t u v w x y z} {
54 if {[file exists $i:]} {
55 lappend result $i:
56 }
57 }
58 if {![llength $result]} {
59 lappend result a: b:
60 }
61 return $result
62 }
63
64 #
65 # This function tries to guess windoze tmp directory, since
66 # the idiots didn't standardize it.
67 proc set_Windoze_tmp {} {
68 global ascUtilVect env ascGlobalVect
69 if {[info exists ascUtilVect(asctmp)] && \
70 [file writable $ascUtilVect(asctmp)] && \
71 [file isdirectory $ascUtilVect(asctmp)]} {
72 if {![info exists env(TMPDIR)]} {
73 set env(TMPDIR) $ascUtilVect(asctmp)
74 }
75 return
76 }
77 set drive [windoze_file_volume]
78 set suffix [list \
79 {/Tmp} \
80 {/Temp} \
81 {/ASCEND IV/Tmp} \
82 {/WinNT/Temp} \
83 {/Win95/Temp} \
84 {/Windows/Temp} \
85 {/Program Files/Temp} \
86 {/Program Files/ASCEND IV/Tmp} \
87 ]
88 set dl {}
89 foreach dr $drive {
90 if {[string compare [string tolower $dr] "a:"] && \
91 [string compare [string tolower $dr] "b:"]} {
92 foreach su $suffix {
93 lappend dl $dr$su
94 }
95 }
96 }
97 if {[info exists ascGlobalVect(userhome)]} {
98 lappend dl $ascGlobalVect(userhome)/../tmp
99 }
100 if {[info exists env(TMPDIR)]} {
101 linsert dl 0 $env(TMPDIR)
102 }
103 if {[info exists env(TMP)]} {
104 linsert dl 0 $env(TMP)
105 }
106 if {[info exists env(TEMP)]} {
107 linsert dl 0 $env(TEMP)
108 }
109 foreach d $dl {
110 set ascUtilVect(asctmp) [file rootname $d ]
111 if {[file isdirectory $ascUtilVect(asctmp)] && \
112 [file writable $ascUtilVect(asctmp)]} {
113 if {![info exists env(TMPDIR)]} {
114 set env(TMPDIR) $ascUtilVect(asctmp)
115 }
116 return
117 }
118 }
119 set ascUtilVect(asctmp) c:/temp
120 if {![info exists env(TMPDIR)]} {
121 set env(TMPDIR) $ascUtilVect(asctmp)
122 }
123 set str "Could not find a writable scratch directory. Tried:"
124 append str " " $dl
125 append str " Open the ASCEND System Utilities tool and set one."
126 append str " Otherwise, some functions like Display Code do not work."
127 Script_Raise_Alert $str
128 return
129 }
130 #
131 # proc set_Util_Defaults {}
132 #------------------------------------------------------------------------
133 # set utility defaults here. note: any values not stored in
134 # utilvect must be initialized elsewhere, eg. set_Toolbox_Defaults
135 #------------------------------------------------------------------------
136 proc set_Util_Defaults {} {
137 global ascUtilVect tcl_platform env
138 if {[string compare $tcl_platform(platform) windows]==0} {
139 set ascUtilVect(edit) "runemacs"
140 set ascUtilVect(ghostview) "ghostview"
141 set_Windoze_tmp
142 set ascUtilVect(plot_type) "xgraph"
143 set ascUtilVect(plot_command) \{$env(ASCENDDIST)
144 append ascUtilVect(plot_command) "/../Tcl/bin/tkxgraph.exe\} -- -f"
145 } else {
146 set ascUtilVect(edit) "emacs"
147 set ascUtilVect(ghostview) "ghostview"
148 set ascUtilVect(asctmp) "/tmp"
149 set ascUtilVect(plot_type) "xgraph"
150 set ascUtilVect(plot_command) "xgraph"
151 }
152 set_Print_Defaults
153 }
154
155 #
156 # proc Util_Init {}
157 #------------------------------------------------------------------------
158 # Utilvect valu check here to guarantee widget creation.
159 # All variables must ultimately resolve to vector entries.
160 # We will _not_ have single variables running around loose in Util
161 #------------------------------------------------------------------------
162 proc Util_Init {} {
163 global ascUtilSubs ascUtilVect
164 set subs "dir"
165 lappend subs asclib ascdist tklib tcllib printer
166 lappend subs print edit ghostview asctmp xspread webstart
167 lappend subs webkick webroot plot_type plot_command
168 # if not set, set dummy so it gets on the util page
169 set alist [array names ascUtilVect]
170 foreach s $subs {
171 if {[lsearch $alist $s]=="-1"} {
172 set ascUtilVect($s) "unset"
173 }
174 }
175 set ascUtilSubs $subs
176 }
177
178 #
179 # proc Util_Get_Label {defsub}
180 #------------------------------------------------------------------------
181 # take a util default subscript and return its label string
182 # for the utility box
183 #------------------------------------------------------------------------
184 proc Util_Get_Label {defsub} {
185 switch $defsub {
186 {asclib} {return "ASCENDLIBRARY path"}
187 {webstart} {return "WWW startup"}
188 {webroot} {return "WWW root URL"}
189 {ascdist} {return "ASCENDDIST dir"}
190 {asctmp} {return "Scratch directory"}
191 {dir} {return "Working Directory"}
192 {edit} {return "Text edit command"}
193 {ghostview} {return "Postscript viewer"}
194 {plot_command} {return "Plot program name"}
195 {plot_type} {return "Plot file type"}
196 {print} {return "Text print command"}
197 {printer} {return "PRINTER"}
198 {webkick} {return "WWW restart"}
199 {tcllib} {return "TCL_LIBRARY"}
200 {tklib} {return "TK_LIBRARY dir"}
201 {xspread} {return "Spreadsheet command"}
202 default {error "util_get_label called with bad option $defsub"}
203 }
204 }
205
206 #
207 # proc Util_Get_Var {defsub}
208 #------------------------------------------------------------------------
209 # take a util default subscript and return its variable
210 # for the utility box. you better have set these vars
211 # elsewhere or trap those not ever set
212 #------------------------------------------------------------------------
213 proc Util_Get_Var {defsub} {
214 switch $defsub {
215 {dir} {return "ascToolVect(dirinput)"}
216 {asclib} {return "env(ASCENDLIBRARY)"}
217 {ascdist} {return "env(ASCENDDIST)"}
218 {webstart} {return "ascHelpVect(start_command)"}
219 {webroot} {return "ascHelpVect(rootURL)"}
220 {asctmp} {return "ascUtilVect(asctmp)"}
221 {tklib} {return "env(TK_LIBRARY)"}
222 {tcllib} {return "env(TCL_LIBRARY)"}
223 {plot_type} {return "ascUtilVect(plot_type)"}
224 {plot_command} {return "ascUtilVect(plot_command)"}
225 {printer} {return "env(PRINTER)"}
226 {print} {return "ascToolVect(printargs)"}
227 {webkick} {return "ascHelpVect(restart_command)"}
228 {ghostview} {return "ascUtilVect(ghostview)"}
229 {edit} {return "ascUtilVect(edit)"}
230 {xspread} {return "ascUtilVect(xspread)"}
231 default {error "util_get_var called with bad option $defsub"}
232 }
233 }
234
235 #
236 # proc Util_do_OK {}
237 #------------------------------------------------------------------------
238 # any return from here before the Destroy leaves the utilbox up.
239 # do sanity checks here where those failing cause a return
240 #------------------------------------------------------------------------
241 proc Util_do_OK {} {
242 global ascUtilSubs ascUtilVect
243 foreach i $ascUtilSubs {
244 set s [Util_Get_Var $i]
245 set aname [lindex [split $s (] 0]
246 global $aname
247 set $s [string trim [set $s]]
248 }
249 if {[catch {Tool_set_dir} ]} {return}
250 global ascUtilVect
251 if {[catch { set ascUtilVect(asctmp) \
252 [file rootname $ascUtilVect(asctmp) ] } ] } {
253 return
254 }
255 if {![file isdirectory $ascUtilVect(asctmp)] || \
256 ![file writable $ascUtilVect(asctmp)]} {
257 set str $ascUtilVect(asctmp)
258 append str " is not a writable Scratch directory"
259 Script_Raise_Alert $str
260 return
261 }
262 Tool_printinstr
263 DestroyWindow.util
264 }
265
266 #
267 # proc Util_do_Read {}
268 #------------------------------------------------------------------------
269 # Reads in settings from ~/ascdata/ascend-config if that is available.
270 #------------------------------------------------------------------------
271 proc Util_do_Read {} {
272 global env
273 set configread 0
274
275 if {!$configread && [file exists ~/ascdata/ascend-config] &&
276 [file readable ~/ascdata/ascend-config] &&
277 ("[file type ~/ascdata/ascend-config]" == "file" ||
278 "[file type ~/ascdata/ascend-config]" == "link")} {
279 if {[catch "uplevel {source [glob ~/ascdata/ascend-config]}" ]} {
280 puts stderr "error in config file: [glob ~/ascdata/ascend-config]"
281 } else {
282 set configread 1
283 }
284 }
285
286 }
287
288 #
289 # proc Util_do_Save {}
290 #------------------------------------------------------------------------
291 # save ~/ascdata/ascend-config. overwrite whatever there.
292 #------------------------------------------------------------------------
293 proc Util_do_Save {} {
294 global ascUtilVect ascGlobalVect
295
296 if {$ascGlobalVect(saveoptions) == 0} {
297 puts stdout "cannot write ascend configure file"
298 return;
299 }
300
301 if {[catch {set conffile [open ~/ascdata/ascend-config w]} ]} {
302 Script_Raise_Alert "Error writing ~/ascdata/ascend-config."
303 return
304 }
305
306 set ostr \
307 "\# Parameters in this file may be changed, saved, and read at any time."
308 puts $conffile $ostr
309 puts $conffile "\# Actions in the .ascendrc are only done at startup time."
310 set ostr \
311 "\# This file is overwritten when toolbox.utilities.save is pressed."
312 puts $conffile $ostr
313 puts $conffile "\# Environment variables are not saved and set here."
314 set subs [lsort [array names ascUtilVect]]
315 foreach s $subs {
316 set varname [Util_Get_Var $s]
317 set aname [lindex [split $varname (] 0]
318 global $varname
319 # we don't save environment vars
320 if {[string range $varname 0 2] !="env"} {
321 puts $conffile " global $aname"
322 puts $conffile " set $varname {[.util.box.main_frm.val_frm.$s get]}"
323 }
324 }
325 close $conffile
326 puts stdout "wrote config file."
327 }
328
329 #
330 # proc Util_do_Help {}
331 #------------------------------------------------------------------------
332 # Util Help button
333 #------------------------------------------------------------------------
334 proc Util_do_Help {} {
335 Help_button utilities
336 }
337
338 #
339 # proc ascFindFile {filename code args}
340 #------------------------------------------------------------------------
341 # File find procedure. baa 3-94
342 # given a filename, a control code, and zero or more searchpaths,
343 # will return the first, last or all matches to a filename in the
344 # search paths.
345 # paths are searched in the order given and may be compound paths
346 # separated by colons.
347 # Each match is returned as a full path name.
348 # filename is first warped to the nativename format
349 # If file starts with / or ~ file will be globbed and the first match
350 # returned rather than searched for.
351 # under windoze, \ or ~ will be globbed instead of / and ~.
352 #
353 # If no path is given, . will be assumed.
354 # If some path is given, . will NOT be assumed
355 # If redundant paths are given, redundant entries will be returned
356 # on the list.
357 #
358 # code must be one of: first last all
359 # for all, return is a list of name elements
360 # for first or last return is a single full path name
361 #------------------------------------------------------------------------
362 proc ascFindFile {filename code args} {
363 global tcl_platform
364 set filename [file nativename $filename]
365 switch $code {
366 {first} -
367 {last} -
368 {all} {}
369 default {error "bad call to ascFindFile: want first last or all"}
370 }
371 if {[file exists $filename]} {
372 if {[file readable $filename]} {
373 return $filename
374 }
375 }
376 set fc [string range $filename 0 0]
377 if {($fc == "/" ) ||
378 ($fc == "\\" && $tcl_platform(platform)=="windows") } {
379 return $filename
380 }
381 if {$fc == "~"} {
382 if {[catch {set tfile [lindex [glob $filename] 0]} foo ]} {
383 puts stderr $foo
384 return ""
385 } {
386 return $tfile
387 }
388 }
389 if {$args == ""} {set searchlist "."} {set searchlist ""}
390 foreach p $args {
391 set dlist ""
392 if {$tcl_platform(platform)=="unix"} {
393 set dlist [split $p :]
394 }
395 if {$tcl_platform(platform)=="windows"} {
396 set dlist [split $p \;]
397 }
398 foreach d $dlist {
399 lappend searchlist $d ;# redundant?
400 }
401 }
402 set foundlist ""
403 set SLASH "/"
404 if {$tcl_platform(platform)=="windows"} {
405 set SLASH "\\"
406 }
407 foreach d $searchlist {
408 if {[file exists "${d}${SLASH}$filename"]} {
409 if {![file readable "${d}${SLASH}$filename"]} {
410 puts stderr "Cannot read $d$SLASH$filename (permission denied)"
411 } else {
412 lappend foundlist ${d}${SLASH}$filename
413 if {$code == "first"} {
414 return [file nativename [lindex $foundlist 0]]
415 }
416 }
417 }
418 }
419 if {$code == "last"} {
420 return [file nativename [lindex $foundlist end]]
421 }
422 return [file nativename $foundlist]
423 }
424
425 #
426 # proc Util_Label_Width {}
427 #------------------------------------------------------------------------
428 # pick out the maximum width of a Util window label
429 #------------------------------------------------------------------------
430 proc Util_Label_Width {} {
431 global ascUtilVect
432 set items [array names ascUtilVect]
433 set wid 0
434 foreach i $items {
435 set sl [string length "[Util_Get_Label $i]"]
436 if {[expr $sl > $wid]} {set wid $sl}
437 }
438 return $wid
439 }
440
441 proc set_Print_Defaults {} {
442 global tcl_platform ascPrintVect env
443 set ascPrintVect(grab) 1
444 set ascPrintVect(cancellable) 1
445 set ascPrintVect(entrywidth) 20
446 set ascPrintVect(npages) 1
447 set ascPrintVect(toplevel) .printconfig
448 set ascPrintVect(title) "Printer setup"
449 set ascPrintVect(helpcommand) {Help_button print}
450 set ascPrintVect(usercheckcommand) Print_checkinput
451 set ascPrintVect(whenokcommand) ""
452 set ascPrintVect(namelist) [list \
453 destination \
454 printername \
455 filename \
456 enscriptflags \
457 customcommand \
458 ]
459 if {$tcl_platform(platform) == "unix"} {
460 set ascPrintVect(destination.choices) [list \
461 {Print} \
462 {Write to file} \
463 {Append to file} \
464 {Enscript} \
465 {Custom}
466 ]
467 } else {
468 # until we can cope with PC idiocy
469 set ascPrintVect(destination.choices) Print
470 }
471 set ascPrintVect(destination) {Print}
472 set ascPrintVect(destination.type) string
473 set ascPrintVect(destination.label) Destination
474 set ascPrintVect(filename) Noname
475 set ascPrintVect(filename.type) string
476 set ascPrintVect(filename.label) "Name of file"
477
478 set ascPrintVect(enscriptflags) {-2rG}
479 set ascPrintVect(enscriptflags.type) string
480 set ascPrintVect(enscriptflags.label) "Enscript flags"
481
482 set ascPrintVect(customcommand) {>> /dev/null cat}
483 set ascPrintVect(customcommand.type) string
484 set ascPrintVect(customcommand.label) "User print command"
485
486 # set the default printer name to mirage, then overwrite it with the
487 # value in the PRINTER or LPDEST environment variable. Finally, set
488 # the PRINTER environment variable so the Utilities window will
489 # display the current printer
490 set ascPrintVect(printername) mirage
491 if {[catch {set ascPrintVect(printername) $env(PRINTER)}]} {
492 catch {set ascPrintVect(printername) $env(LPDEST)}
493 }
494 set env(PRINTER) $ascPrintVect(printername)
495
496 set ascPrintVect(printername.type) string
497 set ascPrintVect(printername.label) "Printer"
498
499 if {$tcl_platform(platform) == "unix"} {
500 # Use SysV-style `lp' command if on HP-UX, IRIX, or Solaris
501 # Use BSD-style `lpr' command everywhere else
502 switch -regexp $tcl_platform(os)$tcl_platform(osVersion) {
503 HP-UX* -
504 IRIX* -
505 SunOS5* {
506 set ascPrintVect(Print) {lp -d%Printer%}
507 set ascPrintVect(Enscript) {enscript %Enscript% -d%Printer%}
508 }
509 default {
510 set ascPrintVect(Print) {lpr -P%Printer%}
511 set ascPrintVect(Enscript) {enscript %Enscript% -P%Printer%}
512 }
513 } ;# endsw
514 set ascPrintVect(Write) {> %File% cat}
515 set ascPrintVect(Append) {>> %File% cat}
516 } else {
517 set ascPrintVect(Print) {notepad /p}
518 # 3 NOT accessed since only Print is offered under windows.
519 set ascPrintVect(Write) {> %File% type}
520 set ascPrintVect(Append) {>> %File% type}
521 set ascPrintVect(Enscript) {enscript %Enscript%P%Printer%}
522 }
523 }
524
525 proc Print_checkinput {args} {
526 global ascToolVect env ascPrintVect
527 set option [lindex $ascPrintVect(destination) 0]
528 switch $option {
529 Print {
530 if {"[stringcompact $ascPrintVect(printername)]" == ""} {
531 error "You must specify a printer"
532 }
533 regsub %Printer% $ascPrintVect(Print) \
534 $ascPrintVect(printername) ascToolVect(printargs)
535 return
536 }
537 Write {
538 if {"[stringcompact $ascPrintVect(filename)]" == ""} {
539 error "You must specify a name for the file written"
540 }
541 set fname [file nativename $ascPrintVect(filename)]
542 if {[file exists $fname]} {
543 if {[file isfile $fname] && [file writable $fname]} {
544 set not [Script_Raise_Alert "File exists. Ok to replace?" \
545 "Print to file question"]
546 if {$not} {error "Please specify a new file name"}
547 } else {
548 error "Please specify a writable file name"
549 }
550 }
551 regsub %File% $ascPrintVect(Write) $fname ascToolVect(printargs)
552 return
553 }
554 Append {
555 if {"[stringcompact $ascPrintVect(filename)]" == ""} {
556 error "You must specify a name for the file to append"
557 }
558 set fname [file nativename $ascPrintVect(filename)]
559 if {![file exists $fname]} {
560 set not [Script_Raise_Alert "File does not exist. Ok to create?" \
561 "Print to file question"]
562 if {$not} {error "Please specify a new file name"}
563 } else {
564 if {![file isfile $fname] || ![file writable $fname]} {
565 error "File not appendable. Please specify a new file name"
566 }
567 }
568 regsub %File% $ascPrintVect(Append) $fname ascToolVect(printargs)
569 return
570 }
571 Enscript {
572 if {"[stringcompact $ascPrintVect(printername)]" == ""} {
573 error "You must specify a printer"
574 }
575 regsub %Printer% $ascPrintVect(Enscript) \
576 $ascPrintVect(printername) tmp1
577 regsub %Enscript% $tmp1 \
578 $ascPrintVect(enscriptflags) ascToolVect(printargs)
579 return
580 }
581 Custom {
582 if {"[stringcompact $ascPrintVect(customcommand)]" == ""} {
583 error "You must specify a custom printing command"
584 }
585 set ascToolVect(printargs) $ascPrintVect(customcommand)
586 return
587 }
588 default {error "Unknown destination specified to print dialog"}
589 } ;# endswitch
590 }
591
592 proc Print_cancelcheck {args} {
593 global ascPrintVect
594 return $ascPrintVect(__,cancelled)
595 }
596
597 #
598 # call this and Print_cancelcheck in sequence always
599 proc Print_configure {window {destination ""}} {
600 global ascToolVect env ascPrintVect
601 set g +10+10
602 catch {
603 set w [winfo toplevel $window]
604 set g "+[winfo x $w]+[winfo y $w]"
605 }
606 if {$destination !=""} {
607 set ascPrintVect(destination) $destination
608 }
609 ascParPage ascPrintVect $g 1
610 set env(PRINTER) $ascPrintVect(printername)
611 set env(LPDEST) $ascPrintVect(printername)
612 }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22