1 # application.tcl --
2 #
3 # The Application class is the base abstraction for the main program of
4 # an application built from mash components.
5 #
6 # Copyright (c) 1996-2002 The Regents of the University of California.
7 # All rights reserved.
8 #
9 # Redistribution and use in source and binary forms, with or without
10 # modification, are permitted provided that the following conditions are met:
11 #
12 # A. Redistributions of source code must retain the above copyright notice,
13 # this list of conditions and the following disclaimer.
14 # B. Redistributions in binary form must reproduce the above copyright notice,
15 # this list of conditions and the following disclaimer in the documentation
16 # and/or other materials provided with the distribution.
17 # C. Neither the names of the copyright holders nor the names of its
18 # contributors may be used to endorse or promote products derived from this
19 # software without specific prior written permission.
20 #
21 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
22 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
25 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
28 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
29 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 #
32 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/common/application.tcl,v 1.49 2002/02/03 04:25:43 lim Exp $
33
34
35 import Log
36
37 #
38 # The Application class is the base abstraction for the main program
39 # of an application built from mash components. There is one application
40 # object per process and it handles the argument parsing, the default
41 # configuration options, and formatting of error messages.
42 # <p>
43 # Warning: this object is intended to offer its subclasses some common
44 # methods for reuse as a mode of convenience, but in general it is safer
45 # to put common functionality in other objects, so as not to restrict
46 # all programs to be subclassed from Application. For example,
47 # programmers shouldn't be forced to subclass from Application to write
48 # a simple mashlet. Likewise, other mash objects should not depend on
49 # the existence of an Application object, since that would restrict
50 # their applicabilty to use in programs that are subclassed from
51 # Application.
52 #
53 Class Application
54
55 #
56 # The Application constructor initializes the application object.
57 # The <i>name</i> argument is a string that identifies the
58 # application, i.e., the name of the application.
59 # The first character of <i>name</i> must be lower case
60 # or results are undefined.
61 #
62 Application public init name {
63 $self next
64 $self instvar name_ class_
65 #
66 # If tk is available, set the name and class fields for
67 # interacting with the tk database. Otherwise, we shouldn't
68 # need them... FIXME actually rtp needs the toolname? this should
69 # be set by the app subclass in the config object
70 #
71 set name_ $name
72
73 $self add_option appname $name
74 Log set name_ $name
75 set class_ [string toupper [string index $name_ 0]][string \
76 range $name_ 1 end]
77 #
78 # Register the app name with tk,
79 # and catch the error in case tk is not compiled in
80 #
81 catch "tk appname $name"
82
83 Application set instance_ $self
84 }
85
86 #
87 # Return a pointer to the sole instance of the application object.
88 # Only one such instance is allowed per process.
89 #
90 Application proc instance {} {
91 return [Application set instance_]
92 }
93
94 Application proc name {} {
95 return [[Application instance] set name_]
96 }
97
98 Application proc class {} {
99 return [[Application instance] set class_]
100 }
101
102 #
103 # Convenient place to put hook to create toplevel windows
104 # FIXME put this elsewhere...?
105 #
106 Application proc toplevel w {
107 Application instvar visual_ colormap_
108 if [info exists visual_] {
109 toplevel $w -class [Application class] \
110 -visual $visual_ -colormap $colormap_
111 } else {
112 toplevel $w -class [Application class]
113 }
114 }
115
116 #FIXME
117 global font
118 set font(helvetica10) {
119 normal--*-100-75-75-*-*-*-*
120 normal--10-*-*-*-*-*-*-*
121 normal--11-*-*-*-*-*-*-*
122 normal--*-100-*-*-*-*-*-*
123 normal--*-*-*-*-*-*-*-*
124 }
125 set font(helvetica12) {
126 normal--*-120-75-75-*-*-*-*
127 normal--12-*-*-*-*-*-*-*
128 normal--14-*-*-*-*-*-*-*
129 normal--*-120-*-*-*-*-*-*
130 normal--*-*-*-*-*-*-*-*
131 }
132 set font(helvetica14) {
133 normal--*-140-75-75-*-*-*-*
134 normal--14-*-*-*-*-*-*-*
135 normal--*-140-*-*-*-*-*-*
136 normal--*-*-*-*-*-*-*-*
137 }
138 set font(times14) {
139 normal--*-140-75-75-*-*-*-*
140 normal--14-*-*-*-*-*-*-*
141 normal--*-140-*-*-*-*-*-*
142 normal--*-*-*-*-*-*-*-*
143 }
144
145 #
146 # This method has been moved to FontInitializer, though not all apps
147 # have been updated to use that object yet. Also, MBapp (a subclass of
148 # Application) redefines this method depending which version of tcl is
149 # being used.
150 #
151 Application instproc search_font { foundry style weight points slant } {
152 global font tcl_version tcl_platform
153
154 if {$tcl_version >= 8} {
155 if {$slant == "r"} {
156 set slant ""
157 } elseif {$slant == "o"} {
158 set slant "italic"
159 }
160 if {$weight == "medium"} {
161 set weight ""
162 }
163 # make points negative since we use pixel size
164 return "$style -$points $weight $slant"
165 }
166
167 foreach f $font($style$points) {
168 set fname -$foundry-$style-$weight-$slant-$f
169 if [havefont $fname] {
170 return $fname
171 }
172 }
173 $self instvar name_
174 puts stderr "$name_: can't find $weight $fname font (using fixed)"
175 if ![havefont fixed] {
176 puts stderr "$name_: can't find fixed font"
177 exit 1
178 }
179 return fixed
180 }
181
182 #
183 # Called to set up local configuration options like those
184 # stored in a preference file. FIXME: get rid of this.
185 #
186 Application public init_local {} {
187 $self instvar name_
188 # $name_.tcl was causing a problem with spurious files
189 # with the same name.
190 set f ~/.$name_.tcl
191 if [file exists $f] {
192 uplevel #0 "source $f"
193 }
194 set script [$self resource startupScript]
195 if { $script != "" } {
196 uplevel #0 "source $script"
197 }
198 }
199
200 # default user_hook is a nop -- users should re-define this in their
201 # ~/.{vic,vat}.tcl to (re-)define procedures to change or augment
202 # the tools behavior.
203
204 Application instproc user_hook {} {
205 }
206
207 #
208 # Every object by default has hooks to look up configuration options.
209 # Any class can overide the "get_option" method, or it can
210 # install a pointer to the options object (in the field options_)
211 # by passing "-optionsFrom $object" to "new"
212 #
213 Object instproc options {} {
214 $self instvar options_
215 if ![info exists options_] {
216 #
217 # If there is no default configuration
218 # object, create it.
219 #
220 Object instvar options_
221 if ![info exists options_] {
222 set options_ [new Configuration]
223 global tcl_platform
224 if {"$tcl_platform(platform)"=="windows"} {
225 $options_ add_default \
226 background SystemButtonFace
227 $options_ add_default \
228 infoHighlightColor SystemHighlightText
229 }
230 }
231 }
232
233 # With this, objects that are not derived from Application will still have an "appname" resource.
234 $options_ add_default appname mash
235
236 return $options_
237 }
238
239 Object instproc optionsFrom o {
240 $self set options_ $o
241 }
242
243 #
244 # Class method that allows classes to declare default configuration
245 # options on a per-class basis, e.g., by given a "-configuration"
246 # option where the Class is defined.
247 #
248 Class instproc configuration a {
249 $self instvar options_
250 if ![info exists options_] {
251 set options_ [new Configuration]
252 }
253 foreach { option value } $a {
254 $options_ add_default $option $value
255 }
256 }
257
258 Object instproc get_option r {
259 set v [[$self options] get_option $r]
260 if { $v != "" } {
261 return $v
262 }
263 #
264 # Option not found. Look through this object's class
265 # hierarchy to see if it can be found there.
266 # Note that this checks Object::options_ since
267 # $self::options_ might point somewhere else
268 # (i.e., to custom object)
269 #
270 set cl [$self info class]
271 foreach cl "$cl [$cl info heritage]" {
272 $cl instvar options_
273 if [info exists options_] {
274 set v [$options_ get_option $r]
275 if { $v != "" } {
276 return $v
277 }
278 }
279 }
280 return ""
281 }
282
283 # FIXME backward compat
284 Object instproc resource r {
285 return [$self get_option $r]
286 }
287
288 Object instproc add_option { r v } {
289 return [[$self options] add_option $r $v]
290 }
291
292 Object instproc add_default { r v } {
293 return [[$self options] add_default $r $v]
294 }
295
296 #
297 # Returns 0 if the value of the option <i>r</i> is false
298 # and returns 1 if the value is true.
299 # (fyi: "" is considered false )
300 #
301 Object instproc yesno r {
302 set v [$self get_option $r]
303 if [string match \[0-9\]* $v] {
304 return $v
305 }
306 if [string match \[tT\]* $v] {
307 return 1
308 }
309 return 0
310 }
311
312 Object instproc debug s {
313 if [$self yesno debug] {
314 Log warn $s
315 }
316 }
317
318 Object instproc warn s {
319 Log warn $s
320 }
321
322 Object instproc fatal s {
323 Log fatal $s
324 }
325
326 #
327 # The base class abstraction for housing and maintaining configuration
328 # options. This is a replacement (and sort of a front-end) for the
329 # Tk options database, which has been far too difficult to make it
330 # do what we need. Any class can create a configuration object
331 # and attach options info to it. In turn, the object can be attached
332 # to any OTcl object using the optionsFrom method. Once installed
333 # in some object, say o, then the get_option and add_options methods
334 # dispatched to $o are diverted to the configuration object.
335 # This approach allows us to embed multiple configuration databases
336 # in a single application.
337 #
338 Class Configuration
339
340 #
341 # Return the option named <i>r</i> stored in this object.
342 # If a binding was established with <i>add_option</i> return
343 # that entry, otherwise return the binding established via
344 # <i>add_default</i>. If no binding exists, return an empty string.
345 #
346 Configuration public get_option r {
347 $self instvar table_ default_
348 if [info exists table_($r)] {
349 return $table_($r)
350 }
351 if [info exists default_($r)] {
352 return $default_($r)
353 }
354 return ""
355 }
356
357 #
358 # Assign the value <i>v</i> to the option named <i>r</i>
359 # in this configuration object. This does not affect the
360 # tk options parameters (as was the convention in the old
361 # mash code base). Now, instead, you must set a tk option
362 # explicitly with the global "option" command.
363 #
364 Configuration public add_option { r v } {
365 $self instvar table_
366 set table_($r) $v
367 }
368
369 #
370 # Assign the value <i>v</i> to the default for the option named <i>r</i>
371 # in this configuration object.
372 #
373 Configuration public add_default { r v } {
374 $self set default_($r) $v
375 }
376
377 #
378 # Register a command-line option with the command-line argument parser
379 # embedded in this application. By registering the command-line option
380 # indicated by the <i>flag</i> argument, the add_option method on
381 # the named Configuration <i>object</i> will be invoked with the
382 # corresponding <i>option</i> argument and the run-time value
383 # encountered. For example:
384 #
385 #<pre>
386 # $app register_option $o -p port
387 #</pre>
388 #
389 # will cause
390 #
391 # <pre>
392 # $o add_option port 1200
393 # </pre>
394 #
395 # to be called when
396 #
397 # <pre>
398 # $app parse_args</i>
399 # </pre>
400 #
401 # is called with the string "-p 1200" somewhere in the argument list.
402 #
403 Configuration public register_option { flag option args } {
404 $self instvar arg_option_ usage_ arg_option_default_
405 set arg_option_($flag) $option
406 if { [lindex $args 0] == "-default" } {
407 set arg_option_default_($flag) [lindex $args 1]
408 set args [lrange $args 2 end]
409 }
410 set usage_($flag) $args
411 }
412
413 Configuration public register_boolean_option { flag option args } {
414 $self instvar arg_bool_ arg_bool_val_
415 set arg_bool_($flag) $option
416 if { $args == "" } {
417 set args 1
418 }
419 set arg_bool_val_($flag) $args
420 }
421
422 #
423 # Similar to <i>register_option</i>, but allows the option to
424 # be specified multiple times on the command line, with all
425 # arguments put in to a list.
426 # For example:
427 #
428 # <pre>
429 # $o register_list_option -map rtpmap
430 # </pre>
431 #
432 # with the argument vector
433 #
434 # <pre>
435 # ... -map 26:jpeg -map 31:h261 ...
436 # </pre>
437 #
438 # will result in the <i>rtpmap</i> option containing the
439 # following Tcl list: {26:jpeg 31:h261}.
440 #
441 Configuration public register_list_option {flag option args} {
442 $self instvar arg_list_option_
443 set arg_list_option_($flag) $option
444 set usage_($flag) $args
445 }
446
447 #
448 # Return true iff the first string of list <i>argv</i> is a
449 # command option (i.e., begins with a dash).
450 #
451 Configuration private is_arg argv {
452 if { $argv != "" } {
453 return [string match -* [lindex $argv 0]]
454 }
455 return 0
456 }
457
458 #
459 # Parse and process the command options in the list of
460 # arguments given by <i>argv</i>. The rules for parsing
461 # arguments are set up by previous calls to <i>register_option</i>.
462 #
463 # Returns the remaining command arguments after stripping
464 # and processing all the options.
465 #
466 # FIXME - actually, if there is an unrecognized option, the "usage" message is
467 # printed and the app exits
468 #
469 Configuration instproc parse_args argv {
470 $self instvar arg_resource_ bool_resource_
471 $self instvar arg_option_ arg_bool_ arg_bool_val_ arg_list_option_ \
472 arg_option_default_
473
474 if { [info exists arg_resource_] || [info exists bool_resource_] } {
475 puts stderr "your application class needs to be fixed"
476 exit 1
477 }
478
479 while 1 {
480 if ![$self is_arg $argv] {
481 break
482 }
483 set arg [lindex $argv 0]
484 set argv [lrange $argv 1 end]
485 set val [lindex $argv 0]
486 if { $arg == "-help" } {
487 $self usage
488 exit
489 }
490 if { $arg == "-X" } {
491 set L [split $val =]
492 if { [llength $L] != 2 } {
493 puts stderr "malformed -X argument"
494 exit 1
495 }
496 $self add_option [lindex $L 0] [lindex $L 1]
497 set argv [lrange $argv 1 end]
498 continue
499 }
500
501 set fatal_msg ""
502 if [info exists arg_option_($arg)] {
503 if { [llength $argv] > 0 && \
504 [string index $val 0]!="-" } {
505 $self add_option $arg_option_($arg) $val
506 set argv [lrange $argv 1 end]
507 continue
508 }
509 set fatal_msg "must be followed by an argument"
510 }
511 if [info exists arg_bool_($arg)] {
512 $self add_option $arg_bool_($arg) $arg_bool_val_($arg)
513 continue
514 }
515 if [info exists arg_list_option_($arg)] {
516 if { [llength $argv] > 0 || \
517 [string index $val 0]!="-" } {
518 set o $arg_list_option_($arg)
519 set l [$self get_option $o]
520 lappend l $val
521 $self add_option $o $l
522 set argv [lrange $argv 1 end]
523 continue
524 }
525 set fatal_msg "must be followed by an argument"
526 }
527 # FIXME - caller should handle
528 # the rest of argv should be passed back
529 $self usage
530 $self fatal "unknown/invalid command option: $arg ($fatal_msg)"
531 }
532 return $argv
533 }
534
535 # The default 'usage' statement. Simply prints out the information of the
536 # argument database returned by Configuration::arg_info.
537 Configuration public usage {} {
538 set display_args_on_single_line 0
539
540 if { $display_args_on_single_line } {
541 puts "usage: [Application name] [join [$self arg_info]]"
542 } else {
543 puts "usage: [Application name]"
544 foreach arg [$self arg_info] {
545 puts $arg
546 }
547 }
548 }
549
550 # Present a human readable version of the argument database. In particular,
551 # identify optional and required arguments and their default values if
552 # applicable. The procedure returns a list with two elements: a list of the
553 # optional arguments and a list of the required arguments. The format is
554 # consistent with standard 'usage' statements with the default values
555 # apprearing in parentheses. Note that if the all arguments to an
556 # application are specified with switches, this information is
557 # sufficient for a 'usage' statement. Otherwise, an application should
558 # derive its own usage statement and use this procedure as part of the
559 # error message.
560 Configuration private arg_info {} {
561 $self instvar arg_option_ arg_bool_ usage_
562
563 foreach arg [array names arg_option_] {
564 set r $arg_option_($arg)
565 # has default?
566 set d [$self get_option $r]
567 if { $d != "" || $usage_($arg) != "required"} {
568 lappend opt "\[$arg $r ($d)\]"
569 } else {
570 lappend req "$arg $r"
571 }
572 }
573
574 foreach arg [array names arg_bool_] {
575 set r $arg_bool_($arg)
576 # has default?
577 set d [$self get_option $r]
578 if { $d != "" } {
579 lappend opt "\[$arg ($d)\]"
580 } else {
581 lappend opt "\[$arg\]"
582 }
583 }
584
585 if [info exists opt] {
586 if [info exists req] {
587 return [concat $opt $req]
588 } else {
589 return $opt
590 }
591 } else {
592 if [info exists req] {
593 return $req
594 } else {
595 return ""
596 }
597 }
598 }
599
600 #
601 # Loads the user preferences profile from persistent storage.
602 # As with parse args, this method uses the argument info that
603 # was previously registered with the register_option method.
604 #
605 Configuration public load_preferences suffixList {
606 global env
607 if {![info exists env(HOME)]} {
608 new ErrorWindow {Your HOME environment variable must be set.}
609 exit 1
610 }
611 set mash [file join $env(HOME) .mash]
612 if {[file isdirectory $mash]} {
613 $self load_file $mash/prefs
614 foreach suffix $suffixList {
615 $self load_file $mash/prefs-$suffix
616 }
617 }
618 }
619
620 #
621 # Load a preference file into the configuration database.
622 # The format of the file is one configuration option per line.
623 # The first word is the key and the remaining words are the value.
624 #
625 Configuration private load_file fname {
626 if ![file readable $fname] {
627 return
628 }
629 set f [open $fname r]
630 set count 0
631 while 1 {
632 incr count
633 if [eof $f] {
634 close $f
635 return
636 }
637 set line [string trim [gets $f]]
638 #FIXME dangerous -- should factor out common piece here.
639
640 # first check if this is a blank line or a comment
641 if { $line == {} || [string index $line 0]=="#" } {
642 continue
643 }
644
645 set colon [string first ":" $line]
646 if { $colon==-1 } {
647 # could not find a colon; must be a file in the old
648 # format; ignore this line and output a warning
649
650 puts stderr "Invalid line $count in $fname:\
651 Must be of the form \"key: value\""
652 continue
653 }
654
655 set option [string trim [string range $line 0 [expr $colon-1]]]
656 set value [string trim [string range $line \
657 [expr $colon+1] end]]
658
659 ## set option [lindex $line 0]
660 ## set value [lrange $line 1 end]
661
662 #FIXME need to find the option in the right data base!
663 $self add_option $option $value
664 }
665 }
666
667
668 Configuration public open_preferences { suffix {mode w} } {
669 global env
670 if {![info exists env(HOME)]} {
671 new ErrorWindow {Your HOME environment variable must be set.}
672 exit 1
673 }
674 set mash [file join $env(HOME) .mash]
675 if {![file exists $mash]} {
676 file mkdir $mash
677 }
678 set f [open $mash/prefs-$suffix $mode 0644]
679 return $f
680 }
681
682
683 Configuration public write_preference { file key value } {
684 puts $file "$key: $value"
685 }
686
687
688 Configuration public close_preferences { file } {
689 close $file
690 }
691
692
693 import ErrorWindow
694
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.