]> www.wagner.pp.ru Git - oss/fgis.git/blob - tcl/objects.tcl
The second attempt to automate building :-) A lot of work here should be
[oss/fgis.git] / tcl / objects.tcl
1 #
2 # objects.tcl
3 # some common procedures to implement fGIS objects
4 # This file is part of fGIS
5 #
6
7
8 #
9 # generates new unique name which starts with prefix.
10 # first name, which is not name of existing Tcl command and
11 #  for which test script returns 1 would be returned
12 #
13 proc fgisMakeObjectName {prefix {test "info exists"}} {
14 set i 0
15 while 1 {
16   set name $prefix$i
17   if {![string length [info command $prefix$i]]&&
18                ![uplevel #0 $test $prefix$i]} {
19      return $prefix$i
20   }
21   incr i
22 }
23 }
24
25 # returns 1 if name can be used for creation of new object
26 #
27 proc fgisCheckName {name {test "info exists"}} {
28  expr ![string length [info command $name]]&&![uplevel #0 $test $name]
29 }
30
31 #
32 # Sets given variable to object value, if passed value is valid command
33 # name.
34 # Second argument specifies, how to deal with empty value.
35 # none - means unset variable
36 # nodefault - raise error
37 # any other value is substituted instead of empty string  
38 # This procedure DELETES object, stored in var previously, if it is
39 # not eqial to default
40 #
41
42 proc fgisSetObj {var default value} {
43   # first, check if we need to substitute defaults
44   if [string match {} $value] {
45       switch -exact -- $default {
46          none { 
47                if {[uplevel info exists $var]&&
48                             "[uplevel set $var]"!="$default"} {
49                   [uplevel set $var] delete
50                }
51              uplevel unset $var
52              return 
53          }
54          nodefault {
55              return -code error -errorcode [list BADVALUE $var] \
56                  "Empty value not allowed"
57          }
58          default {
59              set value $default
60          }
61       }
62    } else {
63        # check if passed value is valid object. Defaults are
64        # not subject to check - programmer knows, but user knows not
65        if [llength [info command $value]]!=1 {
66           return -code error -errorcode [list BADVALUE $var] \
67                "Invalid object \"$value\""
68        }
69    }
70    if {[uplevel info exists $var]&&"[uplevel set $var]"!="$default"} {
71       [uplevel set $var] delete
72    }
73    uplevel set $var [list $value]
74    return
75 }
76
77 #
78 # fgisSetList - sets given variable to value, if value is
79 # one from given list. Otherwise rises error
80
81 proc fgisSetList {var list value} {
82   if [checklistopt value $list msg] {
83       return -code error -errorcode [list BADVALUE $var] $msg
84   }
85   uplevel set $var [list $value]
86   return
87 }